1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- E X P _ C H 6 -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2019, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING3. If not, go to -- 19-- http://www.gnu.org/licenses for a complete copy of the license. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 26with Atree; use Atree; 27with Aspects; use Aspects; 28with Checks; use Checks; 29with Contracts; use Contracts; 30with Debug; use Debug; 31with Einfo; use Einfo; 32with Errout; use Errout; 33with Elists; use Elists; 34with Expander; use Expander; 35with Exp_Aggr; use Exp_Aggr; 36with Exp_Atag; use Exp_Atag; 37with Exp_Ch2; use Exp_Ch2; 38with Exp_Ch3; use Exp_Ch3; 39with Exp_Ch7; use Exp_Ch7; 40with Exp_Ch9; use Exp_Ch9; 41with Exp_Dbug; use Exp_Dbug; 42with Exp_Disp; use Exp_Disp; 43with Exp_Dist; use Exp_Dist; 44with Exp_Intr; use Exp_Intr; 45with Exp_Pakd; use Exp_Pakd; 46with Exp_Tss; use Exp_Tss; 47with Exp_Util; use Exp_Util; 48with Freeze; use Freeze; 49with Inline; use Inline; 50with Itypes; use Itypes; 51with Lib; use Lib; 52with Namet; use Namet; 53with Nlists; use Nlists; 54with Nmake; use Nmake; 55with Opt; use Opt; 56with Restrict; use Restrict; 57with Rident; use Rident; 58with Rtsfind; use Rtsfind; 59with Sem; use Sem; 60with Sem_Aux; use Sem_Aux; 61with Sem_Ch6; use Sem_Ch6; 62with Sem_Ch8; use Sem_Ch8; 63with Sem_Ch12; use Sem_Ch12; 64with Sem_Ch13; use Sem_Ch13; 65with Sem_Dim; use Sem_Dim; 66with Sem_Disp; use Sem_Disp; 67with Sem_Dist; use Sem_Dist; 68with Sem_Eval; use Sem_Eval; 69with Sem_Mech; use Sem_Mech; 70with Sem_Res; use Sem_Res; 71with Sem_SCIL; use Sem_SCIL; 72with Sem_Util; use Sem_Util; 73with Sinfo; use Sinfo; 74with Snames; use Snames; 75with Stand; use Stand; 76with Tbuild; use Tbuild; 77with Uintp; use Uintp; 78with Validsw; use Validsw; 79 80package body Exp_Ch6 is 81 82 ----------------------- 83 -- Local Subprograms -- 84 ----------------------- 85 86 procedure Add_Access_Actual_To_Build_In_Place_Call 87 (Function_Call : Node_Id; 88 Function_Id : Entity_Id; 89 Return_Object : Node_Id; 90 Is_Access : Boolean := False); 91 -- Ada 2005 (AI-318-02): Apply the Unrestricted_Access attribute to the 92 -- object name given by Return_Object and add the attribute to the end of 93 -- the actual parameter list associated with the build-in-place function 94 -- call denoted by Function_Call. However, if Is_Access is True, then 95 -- Return_Object is already an access expression, in which case it's passed 96 -- along directly to the build-in-place function. Finally, if Return_Object 97 -- is empty, then pass a null literal as the actual. 98 99 procedure Add_Unconstrained_Actuals_To_Build_In_Place_Call 100 (Function_Call : Node_Id; 101 Function_Id : Entity_Id; 102 Alloc_Form : BIP_Allocation_Form := Unspecified; 103 Alloc_Form_Exp : Node_Id := Empty; 104 Pool_Actual : Node_Id := Make_Null (No_Location)); 105 -- Ada 2005 (AI-318-02): Add the actuals needed for a build-in-place 106 -- function call that returns a caller-unknown-size result (BIP_Alloc_Form 107 -- and BIP_Storage_Pool). If Alloc_Form_Exp is present, then use it, 108 -- otherwise pass a literal corresponding to the Alloc_Form parameter 109 -- (which must not be Unspecified in that case). Pool_Actual is the 110 -- parameter to pass to BIP_Storage_Pool. 111 112 procedure Add_Finalization_Master_Actual_To_Build_In_Place_Call 113 (Func_Call : Node_Id; 114 Func_Id : Entity_Id; 115 Ptr_Typ : Entity_Id := Empty; 116 Master_Exp : Node_Id := Empty); 117 -- Ada 2005 (AI-318-02): If the result type of a build-in-place call needs 118 -- finalization actions, add an actual parameter which is a pointer to the 119 -- finalization master of the caller. If Master_Exp is not Empty, then that 120 -- will be passed as the actual. Otherwise, if Ptr_Typ is left Empty, this 121 -- will result in an automatic "null" value for the actual. 122 123 procedure Add_Task_Actuals_To_Build_In_Place_Call 124 (Function_Call : Node_Id; 125 Function_Id : Entity_Id; 126 Master_Actual : Node_Id; 127 Chain : Node_Id := Empty); 128 -- Ada 2005 (AI-318-02): For a build-in-place call, if the result type 129 -- contains tasks, add two actual parameters: the master, and a pointer to 130 -- the caller's activation chain. Master_Actual is the actual parameter 131 -- expression to pass for the master. In most cases, this is the current 132 -- master (_master). The two exceptions are: If the function call is the 133 -- initialization expression for an allocator, we pass the master of the 134 -- access type. If the function call is the initialization expression for a 135 -- return object, we pass along the master passed in by the caller. In most 136 -- contexts, the activation chain to pass is the local one, which is 137 -- indicated by No (Chain). However, in an allocator, the caller passes in 138 -- the activation Chain. Note: Master_Actual can be Empty, but only if 139 -- there are no tasks. 140 141 function Caller_Known_Size 142 (Func_Call : Node_Id; 143 Result_Subt : Entity_Id) return Boolean; 144 -- True if result subtype is definite, or has a size that does not require 145 -- secondary stack usage (i.e. no variant part or components whose type 146 -- depends on discriminants). In particular, untagged types with only 147 -- access discriminants do not require secondary stack use. Note we must 148 -- always use the secondary stack for dispatching-on-result calls. 149 150 procedure Check_Overriding_Operation (Subp : Entity_Id); 151 -- Subp is a dispatching operation. Check whether it may override an 152 -- inherited private operation, in which case its DT entry is that of 153 -- the hidden operation, not the one it may have received earlier. 154 -- This must be done before emitting the code to set the corresponding 155 -- DT to the address of the subprogram. The actual placement of Subp in 156 -- the proper place in the list of primitive operations is done in 157 -- Declare_Inherited_Private_Subprograms, which also has to deal with 158 -- implicit operations. This duplication is unavoidable for now??? 159 160 procedure Detect_Infinite_Recursion (N : Node_Id; Spec : Entity_Id); 161 -- This procedure is called only if the subprogram body N, whose spec 162 -- has the given entity Spec, contains a parameterless recursive call. 163 -- It attempts to generate runtime code to detect if this a case of 164 -- infinite recursion. 165 -- 166 -- The body is scanned to determine dependencies. If the only external 167 -- dependencies are on a small set of scalar variables, then the values 168 -- of these variables are captured on entry to the subprogram, and if 169 -- the values are not changed for the call, we know immediately that 170 -- we have an infinite recursion. 171 172 procedure Expand_Actuals 173 (N : Node_Id; 174 Subp : Entity_Id; 175 Post_Call : out List_Id); 176 -- Return a list of actions to take place after the call in Post_Call. The 177 -- call will later be rewritten as an Expression_With_Actions, with the 178 -- Post_Call actions inserted, and the call inside. 179 -- 180 -- For each actual of an in-out or out parameter which is a numeric (view) 181 -- conversion of the form T (A), where A denotes a variable, we insert the 182 -- declaration: 183 -- 184 -- Temp : T[ := T (A)]; 185 -- 186 -- prior to the call. Then we replace the actual with a reference to Temp, 187 -- and append the assignment: 188 -- 189 -- A := TypeA (Temp); 190 -- 191 -- after the call. Here TypeA is the actual type of variable A. For out 192 -- parameters, the initial declaration has no expression. If A is not an 193 -- entity name, we generate instead: 194 -- 195 -- Var : TypeA renames A; 196 -- Temp : T := Var; -- omitting expression for out parameter. 197 -- ... 198 -- Var := TypeA (Temp); 199 -- 200 -- For other in-out parameters, we emit the required constraint checks 201 -- before and/or after the call. 202 -- 203 -- For all parameter modes, actuals that denote components and slices of 204 -- packed arrays are expanded into suitable temporaries. 205 -- 206 -- For non-scalar objects that are possibly unaligned, add call by copy 207 -- code (copy in for IN and IN OUT, copy out for OUT and IN OUT). 208 -- 209 -- For OUT and IN OUT parameters, add predicate checks after the call 210 -- based on the predicates of the actual type. 211 212 procedure Expand_Call_Helper (N : Node_Id; Post_Call : out List_Id); 213 -- Does the main work of Expand_Call. Post_Call is as for Expand_Actuals. 214 215 procedure Expand_Ctrl_Function_Call (N : Node_Id); 216 -- N is a function call which returns a controlled object. Transform the 217 -- call into a temporary which retrieves the returned object from the 218 -- secondary stack using 'reference. 219 220 procedure Expand_Non_Function_Return (N : Node_Id); 221 -- Expand a simple return statement found in a procedure body, entry body, 222 -- accept statement, or an extended return statement. Note that all non- 223 -- function returns are simple return statements. 224 225 function Expand_Protected_Object_Reference 226 (N : Node_Id; 227 Scop : Entity_Id) return Node_Id; 228 229 procedure Expand_Protected_Subprogram_Call 230 (N : Node_Id; 231 Subp : Entity_Id; 232 Scop : Entity_Id); 233 -- A call to a protected subprogram within the protected object may appear 234 -- as a regular call. The list of actuals must be expanded to contain a 235 -- reference to the object itself, and the call becomes a call to the 236 -- corresponding protected subprogram. 237 238 procedure Expand_Simple_Function_Return (N : Node_Id); 239 -- Expand simple return from function. In the case where we are returning 240 -- from a function body this is called by Expand_N_Simple_Return_Statement. 241 242 function Has_Unconstrained_Access_Discriminants 243 (Subtyp : Entity_Id) return Boolean; 244 -- Returns True if the given subtype is unconstrained and has one or more 245 -- access discriminants. 246 247 procedure Insert_Post_Call_Actions (N : Node_Id; Post_Call : List_Id); 248 -- Insert the Post_Call list previously produced by routine Expand_Actuals 249 -- or Expand_Call_Helper into the tree. 250 251 procedure Replace_Renaming_Declaration_Id 252 (New_Decl : Node_Id; 253 Orig_Decl : Node_Id); 254 -- Replace the internal identifier of the new renaming declaration New_Decl 255 -- with the identifier of its original declaration Orig_Decl exchanging the 256 -- entities containing their defining identifiers to ensure the correct 257 -- replacement of the object declaration by the object renaming declaration 258 -- to avoid homograph conflicts (since the object declaration's defining 259 -- identifier was already entered in the current scope). The Next_Entity 260 -- links of the two entities are also swapped since the entities are part 261 -- of the return scope's entity list and the list structure would otherwise 262 -- be corrupted. The homonym chain is preserved as well. 263 264 procedure Rewrite_Function_Call_For_C (N : Node_Id); 265 -- When generating C code, replace a call to a function that returns an 266 -- array into the generated procedure with an additional out parameter. 267 268 procedure Set_Enclosing_Sec_Stack_Return (N : Node_Id); 269 -- N is a return statement for a function that returns its result on the 270 -- secondary stack. This sets the Sec_Stack_Needed_For_Return flag on the 271 -- function and all blocks and loops that the return statement is jumping 272 -- out of. This ensures that the secondary stack is not released; otherwise 273 -- the function result would be reclaimed before returning to the caller. 274 275 ---------------------------------------------- 276 -- Add_Access_Actual_To_Build_In_Place_Call -- 277 ---------------------------------------------- 278 279 procedure Add_Access_Actual_To_Build_In_Place_Call 280 (Function_Call : Node_Id; 281 Function_Id : Entity_Id; 282 Return_Object : Node_Id; 283 Is_Access : Boolean := False) 284 is 285 Loc : constant Source_Ptr := Sloc (Function_Call); 286 Obj_Address : Node_Id; 287 Obj_Acc_Formal : Entity_Id; 288 289 begin 290 -- Locate the implicit access parameter in the called function 291 292 Obj_Acc_Formal := Build_In_Place_Formal (Function_Id, BIP_Object_Access); 293 294 -- If no return object is provided, then pass null 295 296 if not Present (Return_Object) then 297 Obj_Address := Make_Null (Loc); 298 Set_Parent (Obj_Address, Function_Call); 299 300 -- If Return_Object is already an expression of an access type, then use 301 -- it directly, since it must be an access value denoting the return 302 -- object, and couldn't possibly be the return object itself. 303 304 elsif Is_Access then 305 Obj_Address := Return_Object; 306 Set_Parent (Obj_Address, Function_Call); 307 308 -- Apply Unrestricted_Access to caller's return object 309 310 else 311 Obj_Address := 312 Make_Attribute_Reference (Loc, 313 Prefix => Return_Object, 314 Attribute_Name => Name_Unrestricted_Access); 315 316 Set_Parent (Return_Object, Obj_Address); 317 Set_Parent (Obj_Address, Function_Call); 318 end if; 319 320 Analyze_And_Resolve (Obj_Address, Etype (Obj_Acc_Formal)); 321 322 -- Build the parameter association for the new actual and add it to the 323 -- end of the function's actuals. 324 325 Add_Extra_Actual_To_Call (Function_Call, Obj_Acc_Formal, Obj_Address); 326 end Add_Access_Actual_To_Build_In_Place_Call; 327 328 ------------------------------------------------------ 329 -- Add_Unconstrained_Actuals_To_Build_In_Place_Call -- 330 ------------------------------------------------------ 331 332 procedure Add_Unconstrained_Actuals_To_Build_In_Place_Call 333 (Function_Call : Node_Id; 334 Function_Id : Entity_Id; 335 Alloc_Form : BIP_Allocation_Form := Unspecified; 336 Alloc_Form_Exp : Node_Id := Empty; 337 Pool_Actual : Node_Id := Make_Null (No_Location)) 338 is 339 Loc : constant Source_Ptr := Sloc (Function_Call); 340 341 Alloc_Form_Actual : Node_Id; 342 Alloc_Form_Formal : Node_Id; 343 Pool_Formal : Node_Id; 344 345 begin 346 -- Nothing to do when the size of the object is known, and the caller is 347 -- in charge of allocating it, and the callee doesn't unconditionally 348 -- require an allocation form (such as due to having a tagged result). 349 350 if not Needs_BIP_Alloc_Form (Function_Id) then 351 return; 352 end if; 353 354 -- Locate the implicit allocation form parameter in the called function. 355 -- Maybe it would be better for each implicit formal of a build-in-place 356 -- function to have a flag or a Uint attribute to identify it. ??? 357 358 Alloc_Form_Formal := Build_In_Place_Formal (Function_Id, BIP_Alloc_Form); 359 360 if Present (Alloc_Form_Exp) then 361 pragma Assert (Alloc_Form = Unspecified); 362 363 Alloc_Form_Actual := Alloc_Form_Exp; 364 365 else 366 pragma Assert (Alloc_Form /= Unspecified); 367 368 Alloc_Form_Actual := 369 Make_Integer_Literal (Loc, 370 Intval => UI_From_Int (BIP_Allocation_Form'Pos (Alloc_Form))); 371 end if; 372 373 Analyze_And_Resolve (Alloc_Form_Actual, Etype (Alloc_Form_Formal)); 374 375 -- Build the parameter association for the new actual and add it to the 376 -- end of the function's actuals. 377 378 Add_Extra_Actual_To_Call 379 (Function_Call, Alloc_Form_Formal, Alloc_Form_Actual); 380 381 -- Pass the Storage_Pool parameter. This parameter is omitted on ZFP as 382 -- those targets do not support pools. 383 384 if RTE_Available (RE_Root_Storage_Pool_Ptr) then 385 Pool_Formal := Build_In_Place_Formal (Function_Id, BIP_Storage_Pool); 386 Analyze_And_Resolve (Pool_Actual, Etype (Pool_Formal)); 387 Add_Extra_Actual_To_Call 388 (Function_Call, Pool_Formal, Pool_Actual); 389 end if; 390 end Add_Unconstrained_Actuals_To_Build_In_Place_Call; 391 392 ----------------------------------------------------------- 393 -- Add_Finalization_Master_Actual_To_Build_In_Place_Call -- 394 ----------------------------------------------------------- 395 396 procedure Add_Finalization_Master_Actual_To_Build_In_Place_Call 397 (Func_Call : Node_Id; 398 Func_Id : Entity_Id; 399 Ptr_Typ : Entity_Id := Empty; 400 Master_Exp : Node_Id := Empty) 401 is 402 begin 403 if not Needs_BIP_Finalization_Master (Func_Id) then 404 return; 405 end if; 406 407 declare 408 Formal : constant Entity_Id := 409 Build_In_Place_Formal (Func_Id, BIP_Finalization_Master); 410 Loc : constant Source_Ptr := Sloc (Func_Call); 411 412 Actual : Node_Id; 413 Desig_Typ : Entity_Id; 414 415 begin 416 -- If there is a finalization master actual, such as the implicit 417 -- finalization master of an enclosing build-in-place function, 418 -- then this must be added as an extra actual of the call. 419 420 if Present (Master_Exp) then 421 Actual := Master_Exp; 422 423 -- Case where the context does not require an actual master 424 425 elsif No (Ptr_Typ) then 426 Actual := Make_Null (Loc); 427 428 else 429 Desig_Typ := Directly_Designated_Type (Ptr_Typ); 430 431 -- Check for a library-level access type whose designated type has 432 -- suppressed finalization or the access type is subject to pragma 433 -- No_Heap_Finalization. Such an access type lacks a master. Pass 434 -- a null actual to callee in order to signal a missing master. 435 436 if Is_Library_Level_Entity (Ptr_Typ) 437 and then (Finalize_Storage_Only (Desig_Typ) 438 or else No_Heap_Finalization (Ptr_Typ)) 439 then 440 Actual := Make_Null (Loc); 441 442 -- Types in need of finalization actions 443 444 elsif Needs_Finalization (Desig_Typ) then 445 446 -- The general mechanism of creating finalization masters for 447 -- anonymous access types is disabled by default, otherwise 448 -- finalization masters will pop all over the place. Such types 449 -- use context-specific masters. 450 451 if Ekind (Ptr_Typ) = E_Anonymous_Access_Type 452 and then No (Finalization_Master (Ptr_Typ)) 453 then 454 Build_Anonymous_Master (Ptr_Typ); 455 end if; 456 457 -- Access-to-controlled types should always have a master 458 459 pragma Assert (Present (Finalization_Master (Ptr_Typ))); 460 461 Actual := 462 Make_Attribute_Reference (Loc, 463 Prefix => 464 New_Occurrence_Of (Finalization_Master (Ptr_Typ), Loc), 465 Attribute_Name => Name_Unrestricted_Access); 466 467 -- Tagged types 468 469 else 470 Actual := Make_Null (Loc); 471 end if; 472 end if; 473 474 Analyze_And_Resolve (Actual, Etype (Formal)); 475 476 -- Build the parameter association for the new actual and add it to 477 -- the end of the function's actuals. 478 479 Add_Extra_Actual_To_Call (Func_Call, Formal, Actual); 480 end; 481 end Add_Finalization_Master_Actual_To_Build_In_Place_Call; 482 483 ------------------------------ 484 -- Add_Extra_Actual_To_Call -- 485 ------------------------------ 486 487 procedure Add_Extra_Actual_To_Call 488 (Subprogram_Call : Node_Id; 489 Extra_Formal : Entity_Id; 490 Extra_Actual : Node_Id) 491 is 492 Loc : constant Source_Ptr := Sloc (Subprogram_Call); 493 Param_Assoc : Node_Id; 494 495 begin 496 Param_Assoc := 497 Make_Parameter_Association (Loc, 498 Selector_Name => New_Occurrence_Of (Extra_Formal, Loc), 499 Explicit_Actual_Parameter => Extra_Actual); 500 501 Set_Parent (Param_Assoc, Subprogram_Call); 502 Set_Parent (Extra_Actual, Param_Assoc); 503 504 if Present (Parameter_Associations (Subprogram_Call)) then 505 if Nkind (Last (Parameter_Associations (Subprogram_Call))) = 506 N_Parameter_Association 507 then 508 509 -- Find last named actual, and append 510 511 declare 512 L : Node_Id; 513 begin 514 L := First_Actual (Subprogram_Call); 515 while Present (L) loop 516 if No (Next_Actual (L)) then 517 Set_Next_Named_Actual (Parent (L), Extra_Actual); 518 exit; 519 end if; 520 Next_Actual (L); 521 end loop; 522 end; 523 524 else 525 Set_First_Named_Actual (Subprogram_Call, Extra_Actual); 526 end if; 527 528 Append (Param_Assoc, To => Parameter_Associations (Subprogram_Call)); 529 530 else 531 Set_Parameter_Associations (Subprogram_Call, New_List (Param_Assoc)); 532 Set_First_Named_Actual (Subprogram_Call, Extra_Actual); 533 end if; 534 end Add_Extra_Actual_To_Call; 535 536 --------------------------------------------- 537 -- Add_Task_Actuals_To_Build_In_Place_Call -- 538 --------------------------------------------- 539 540 procedure Add_Task_Actuals_To_Build_In_Place_Call 541 (Function_Call : Node_Id; 542 Function_Id : Entity_Id; 543 Master_Actual : Node_Id; 544 Chain : Node_Id := Empty) 545 is 546 Loc : constant Source_Ptr := Sloc (Function_Call); 547 Result_Subt : constant Entity_Id := 548 Available_View (Etype (Function_Id)); 549 Actual : Node_Id; 550 Chain_Actual : Node_Id; 551 Chain_Formal : Node_Id; 552 Master_Formal : Node_Id; 553 554 begin 555 -- No such extra parameters are needed if there are no tasks 556 557 if not Has_Task (Result_Subt) then 558 return; 559 end if; 560 561 Actual := Master_Actual; 562 563 -- Use a dummy _master actual in case of No_Task_Hierarchy 564 565 if Restriction_Active (No_Task_Hierarchy) then 566 Actual := New_Occurrence_Of (RTE (RE_Library_Task_Level), Loc); 567 568 -- In the case where we use the master associated with an access type, 569 -- the actual is an entity and requires an explicit reference. 570 571 elsif Nkind (Actual) = N_Defining_Identifier then 572 Actual := New_Occurrence_Of (Actual, Loc); 573 end if; 574 575 -- Locate the implicit master parameter in the called function 576 577 Master_Formal := Build_In_Place_Formal (Function_Id, BIP_Task_Master); 578 Analyze_And_Resolve (Actual, Etype (Master_Formal)); 579 580 -- Build the parameter association for the new actual and add it to the 581 -- end of the function's actuals. 582 583 Add_Extra_Actual_To_Call (Function_Call, Master_Formal, Actual); 584 585 -- Locate the implicit activation chain parameter in the called function 586 587 Chain_Formal := 588 Build_In_Place_Formal (Function_Id, BIP_Activation_Chain); 589 590 -- Create the actual which is a pointer to the current activation chain 591 592 if No (Chain) then 593 Chain_Actual := 594 Make_Attribute_Reference (Loc, 595 Prefix => Make_Identifier (Loc, Name_uChain), 596 Attribute_Name => Name_Unrestricted_Access); 597 598 -- Allocator case; make a reference to the Chain passed in by the caller 599 600 else 601 Chain_Actual := 602 Make_Attribute_Reference (Loc, 603 Prefix => New_Occurrence_Of (Chain, Loc), 604 Attribute_Name => Name_Unrestricted_Access); 605 end if; 606 607 Analyze_And_Resolve (Chain_Actual, Etype (Chain_Formal)); 608 609 -- Build the parameter association for the new actual and add it to the 610 -- end of the function's actuals. 611 612 Add_Extra_Actual_To_Call (Function_Call, Chain_Formal, Chain_Actual); 613 end Add_Task_Actuals_To_Build_In_Place_Call; 614 615 ----------------------- 616 -- BIP_Formal_Suffix -- 617 ----------------------- 618 619 function BIP_Formal_Suffix (Kind : BIP_Formal_Kind) return String is 620 begin 621 case Kind is 622 when BIP_Alloc_Form => 623 return "BIPalloc"; 624 625 when BIP_Storage_Pool => 626 return "BIPstoragepool"; 627 628 when BIP_Finalization_Master => 629 return "BIPfinalizationmaster"; 630 631 when BIP_Task_Master => 632 return "BIPtaskmaster"; 633 634 when BIP_Activation_Chain => 635 return "BIPactivationchain"; 636 637 when BIP_Object_Access => 638 return "BIPaccess"; 639 end case; 640 end BIP_Formal_Suffix; 641 642 --------------------------- 643 -- Build_In_Place_Formal -- 644 --------------------------- 645 646 function Build_In_Place_Formal 647 (Func : Entity_Id; 648 Kind : BIP_Formal_Kind) return Entity_Id 649 is 650 Formal_Suffix : constant String := BIP_Formal_Suffix (Kind); 651 Extra_Formal : Entity_Id := Extra_Formals (Func); 652 653 begin 654 -- Maybe it would be better for each implicit formal of a build-in-place 655 -- function to have a flag or a Uint attribute to identify it. ??? 656 657 -- The return type in the function declaration may have been a limited 658 -- view, and the extra formals for the function were not generated at 659 -- that point. At the point of call the full view must be available and 660 -- the extra formals can be created. 661 662 if No (Extra_Formal) then 663 Create_Extra_Formals (Func); 664 Extra_Formal := Extra_Formals (Func); 665 end if; 666 667 -- We search for a formal with a matching suffix. We can't search 668 -- for the full name, because of the code at the end of Sem_Ch6.- 669 -- Create_Extra_Formals, which copies the Extra_Formals over to 670 -- the Alias of an instance, which will cause the formals to have 671 -- "incorrect" names. 672 673 loop 674 pragma Assert (Present (Extra_Formal)); 675 declare 676 Name : constant String := Get_Name_String (Chars (Extra_Formal)); 677 begin 678 exit when Name'Length >= Formal_Suffix'Length 679 and then Formal_Suffix = 680 Name (Name'Last - Formal_Suffix'Length + 1 .. Name'Last); 681 end; 682 683 Next_Formal_With_Extras (Extra_Formal); 684 end loop; 685 686 return Extra_Formal; 687 end Build_In_Place_Formal; 688 689 ------------------------------- 690 -- Build_Procedure_Body_Form -- 691 ------------------------------- 692 693 function Build_Procedure_Body_Form 694 (Func_Id : Entity_Id; 695 Func_Body : Node_Id) return Node_Id 696 is 697 Loc : constant Source_Ptr := Sloc (Func_Body); 698 699 Proc_Decl : constant Node_Id := 700 Next (Unit_Declaration_Node (Func_Id)); 701 -- It is assumed that the next node following the declaration of the 702 -- corresponding subprogram spec is the declaration of the procedure 703 -- form. 704 705 Proc_Id : constant Entity_Id := Defining_Entity (Proc_Decl); 706 707 procedure Replace_Returns (Param_Id : Entity_Id; Stmts : List_Id); 708 -- Replace each return statement found in the list Stmts with an 709 -- assignment of the return expression to parameter Param_Id. 710 711 --------------------- 712 -- Replace_Returns -- 713 --------------------- 714 715 procedure Replace_Returns (Param_Id : Entity_Id; Stmts : List_Id) is 716 Stmt : Node_Id; 717 718 begin 719 Stmt := First (Stmts); 720 while Present (Stmt) loop 721 if Nkind (Stmt) = N_Block_Statement then 722 Replace_Returns (Param_Id, 723 Statements (Handled_Statement_Sequence (Stmt))); 724 725 elsif Nkind (Stmt) = N_Case_Statement then 726 declare 727 Alt : Node_Id; 728 begin 729 Alt := First (Alternatives (Stmt)); 730 while Present (Alt) loop 731 Replace_Returns (Param_Id, Statements (Alt)); 732 Next (Alt); 733 end loop; 734 end; 735 736 elsif Nkind (Stmt) = N_Extended_Return_Statement then 737 declare 738 Ret_Obj : constant Entity_Id := 739 Defining_Entity 740 (First (Return_Object_Declarations (Stmt))); 741 Assign : constant Node_Id := 742 Make_Assignment_Statement (Sloc (Stmt), 743 Name => 744 New_Occurrence_Of (Param_Id, Loc), 745 Expression => 746 New_Occurrence_Of (Ret_Obj, Sloc (Stmt))); 747 Stmts : List_Id; 748 749 begin 750 -- The extended return may just contain the declaration 751 752 if Present (Handled_Statement_Sequence (Stmt)) then 753 Stmts := Statements (Handled_Statement_Sequence (Stmt)); 754 else 755 Stmts := New_List; 756 end if; 757 758 Set_Assignment_OK (Name (Assign)); 759 760 Rewrite (Stmt, 761 Make_Block_Statement (Sloc (Stmt), 762 Declarations => 763 Return_Object_Declarations (Stmt), 764 Handled_Statement_Sequence => 765 Make_Handled_Sequence_Of_Statements (Loc, 766 Statements => Stmts))); 767 768 Replace_Returns (Param_Id, Stmts); 769 770 Append_To (Stmts, Assign); 771 Append_To (Stmts, Make_Simple_Return_Statement (Loc)); 772 end; 773 774 elsif Nkind (Stmt) = N_If_Statement then 775 Replace_Returns (Param_Id, Then_Statements (Stmt)); 776 Replace_Returns (Param_Id, Else_Statements (Stmt)); 777 778 declare 779 Part : Node_Id; 780 begin 781 Part := First (Elsif_Parts (Stmt)); 782 while Present (Part) loop 783 Replace_Returns (Param_Id, Then_Statements (Part)); 784 Next (Part); 785 end loop; 786 end; 787 788 elsif Nkind (Stmt) = N_Loop_Statement then 789 Replace_Returns (Param_Id, Statements (Stmt)); 790 791 elsif Nkind (Stmt) = N_Simple_Return_Statement then 792 793 -- Generate: 794 -- Param := Expr; 795 -- return; 796 797 Rewrite (Stmt, 798 Make_Assignment_Statement (Sloc (Stmt), 799 Name => New_Occurrence_Of (Param_Id, Loc), 800 Expression => Relocate_Node (Expression (Stmt)))); 801 802 Insert_After (Stmt, Make_Simple_Return_Statement (Loc)); 803 804 -- Skip the added return 805 806 Next (Stmt); 807 end if; 808 809 Next (Stmt); 810 end loop; 811 end Replace_Returns; 812 813 -- Local variables 814 815 Stmts : List_Id; 816 New_Body : Node_Id; 817 818 -- Start of processing for Build_Procedure_Body_Form 819 820 begin 821 -- This routine replaces the original function body: 822 823 -- function F (...) return Array_Typ is 824 -- begin 825 -- ... 826 -- return Something; 827 -- end F; 828 829 -- with the following: 830 831 -- procedure P (..., Result : out Array_Typ) is 832 -- begin 833 -- ... 834 -- Result := Something; 835 -- end P; 836 837 Stmts := 838 Statements (Handled_Statement_Sequence (Func_Body)); 839 Replace_Returns (Last_Entity (Proc_Id), Stmts); 840 841 New_Body := 842 Make_Subprogram_Body (Loc, 843 Specification => 844 Copy_Subprogram_Spec (Specification (Proc_Decl)), 845 Declarations => Declarations (Func_Body), 846 Handled_Statement_Sequence => 847 Make_Handled_Sequence_Of_Statements (Loc, 848 Statements => Stmts)); 849 850 -- If the function is a generic instance, so is the new procedure. 851 -- Set flag accordingly so that the proper renaming declarations are 852 -- generated. 853 854 Set_Is_Generic_Instance (Proc_Id, Is_Generic_Instance (Func_Id)); 855 return New_Body; 856 end Build_Procedure_Body_Form; 857 858 ----------------------- 859 -- Caller_Known_Size -- 860 ----------------------- 861 862 function Caller_Known_Size 863 (Func_Call : Node_Id; 864 Result_Subt : Entity_Id) return Boolean 865 is 866 begin 867 return 868 (Is_Definite_Subtype (Underlying_Type (Result_Subt)) 869 and then No (Controlling_Argument (Func_Call))) 870 or else not Requires_Transient_Scope (Underlying_Type (Result_Subt)); 871 end Caller_Known_Size; 872 873 -------------------------------- 874 -- Check_Overriding_Operation -- 875 -------------------------------- 876 877 procedure Check_Overriding_Operation (Subp : Entity_Id) is 878 Typ : constant Entity_Id := Find_Dispatching_Type (Subp); 879 Op_List : constant Elist_Id := Primitive_Operations (Typ); 880 Op_Elmt : Elmt_Id; 881 Prim_Op : Entity_Id; 882 Par_Op : Entity_Id; 883 884 begin 885 if Is_Derived_Type (Typ) 886 and then not Is_Private_Type (Typ) 887 and then In_Open_Scopes (Scope (Etype (Typ))) 888 and then Is_Base_Type (Typ) 889 then 890 -- Subp overrides an inherited private operation if there is an 891 -- inherited operation with a different name than Subp (see 892 -- Derive_Subprogram) whose Alias is a hidden subprogram with the 893 -- same name as Subp. 894 895 Op_Elmt := First_Elmt (Op_List); 896 while Present (Op_Elmt) loop 897 Prim_Op := Node (Op_Elmt); 898 Par_Op := Alias (Prim_Op); 899 900 if Present (Par_Op) 901 and then not Comes_From_Source (Prim_Op) 902 and then Chars (Prim_Op) /= Chars (Par_Op) 903 and then Chars (Par_Op) = Chars (Subp) 904 and then Is_Hidden (Par_Op) 905 and then Type_Conformant (Prim_Op, Subp) 906 then 907 Set_DT_Position_Value (Subp, DT_Position (Prim_Op)); 908 end if; 909 910 Next_Elmt (Op_Elmt); 911 end loop; 912 end if; 913 end Check_Overriding_Operation; 914 915 ------------------------------- 916 -- Detect_Infinite_Recursion -- 917 ------------------------------- 918 919 procedure Detect_Infinite_Recursion (N : Node_Id; Spec : Entity_Id) is 920 Loc : constant Source_Ptr := Sloc (N); 921 922 Var_List : constant Elist_Id := New_Elmt_List; 923 -- List of globals referenced by body of procedure 924 925 Call_List : constant Elist_Id := New_Elmt_List; 926 -- List of recursive calls in body of procedure 927 928 Shad_List : constant Elist_Id := New_Elmt_List; 929 -- List of entity id's for entities created to capture the value of 930 -- referenced globals on entry to the procedure. 931 932 Scop : constant Uint := Scope_Depth (Spec); 933 -- This is used to record the scope depth of the current procedure, so 934 -- that we can identify global references. 935 936 Max_Vars : constant := 4; 937 -- Do not test more than four global variables 938 939 Count_Vars : Natural := 0; 940 -- Count variables found so far 941 942 Var : Entity_Id; 943 Elm : Elmt_Id; 944 Ent : Entity_Id; 945 Call : Elmt_Id; 946 Decl : Node_Id; 947 Test : Node_Id; 948 Elm1 : Elmt_Id; 949 Elm2 : Elmt_Id; 950 Last : Node_Id; 951 952 function Process (Nod : Node_Id) return Traverse_Result; 953 -- Function to traverse the subprogram body (using Traverse_Func) 954 955 ------------- 956 -- Process -- 957 ------------- 958 959 function Process (Nod : Node_Id) return Traverse_Result is 960 begin 961 -- Procedure call 962 963 if Nkind (Nod) = N_Procedure_Call_Statement then 964 965 -- Case of one of the detected recursive calls 966 967 if Is_Entity_Name (Name (Nod)) 968 and then Has_Recursive_Call (Entity (Name (Nod))) 969 and then Entity (Name (Nod)) = Spec 970 then 971 Append_Elmt (Nod, Call_List); 972 return Skip; 973 974 -- Any other procedure call may have side effects 975 976 else 977 return Abandon; 978 end if; 979 980 -- A call to a pure function can always be ignored 981 982 elsif Nkind (Nod) = N_Function_Call 983 and then Is_Entity_Name (Name (Nod)) 984 and then Is_Pure (Entity (Name (Nod))) 985 then 986 return Skip; 987 988 -- Case of an identifier reference 989 990 elsif Nkind (Nod) = N_Identifier then 991 Ent := Entity (Nod); 992 993 -- If no entity, then ignore the reference 994 995 -- Not clear why this can happen. To investigate, remove this 996 -- test and look at the crash that occurs here in 3401-004 ??? 997 998 if No (Ent) then 999 return Skip; 1000 1001 -- Ignore entities with no Scope, again not clear how this 1002 -- can happen, to investigate, look at 4108-008 ??? 1003 1004 elsif No (Scope (Ent)) then 1005 return Skip; 1006 1007 -- Ignore the reference if not to a more global object 1008 1009 elsif Scope_Depth (Scope (Ent)) >= Scop then 1010 return Skip; 1011 1012 -- References to types, exceptions and constants are always OK 1013 1014 elsif Is_Type (Ent) 1015 or else Ekind (Ent) = E_Exception 1016 or else Ekind (Ent) = E_Constant 1017 then 1018 return Skip; 1019 1020 -- If other than a non-volatile scalar variable, we have some 1021 -- kind of global reference (e.g. to a function) that we cannot 1022 -- deal with so we forget the attempt. 1023 1024 elsif Ekind (Ent) /= E_Variable 1025 or else not Is_Scalar_Type (Etype (Ent)) 1026 or else Treat_As_Volatile (Ent) 1027 then 1028 return Abandon; 1029 1030 -- Otherwise we have a reference to a global scalar 1031 1032 else 1033 -- Loop through global entities already detected 1034 1035 Elm := First_Elmt (Var_List); 1036 loop 1037 -- If not detected before, record this new global reference 1038 1039 if No (Elm) then 1040 Count_Vars := Count_Vars + 1; 1041 1042 if Count_Vars <= Max_Vars then 1043 Append_Elmt (Entity (Nod), Var_List); 1044 else 1045 return Abandon; 1046 end if; 1047 1048 exit; 1049 1050 -- If recorded before, ignore 1051 1052 elsif Node (Elm) = Entity (Nod) then 1053 return Skip; 1054 1055 -- Otherwise keep looking 1056 1057 else 1058 Next_Elmt (Elm); 1059 end if; 1060 end loop; 1061 1062 return Skip; 1063 end if; 1064 1065 -- For all other node kinds, recursively visit syntactic children 1066 1067 else 1068 return OK; 1069 end if; 1070 end Process; 1071 1072 function Traverse_Body is new Traverse_Func (Process); 1073 1074 -- Start of processing for Detect_Infinite_Recursion 1075 1076 begin 1077 -- Do not attempt detection in No_Implicit_Conditional mode, since we 1078 -- won't be able to generate the code to handle the recursion in any 1079 -- case. 1080 1081 if Restriction_Active (No_Implicit_Conditionals) then 1082 return; 1083 end if; 1084 1085 -- Otherwise do traversal and quit if we get abandon signal 1086 1087 if Traverse_Body (N) = Abandon then 1088 return; 1089 1090 -- We must have a call, since Has_Recursive_Call was set. If not just 1091 -- ignore (this is only an error check, so if we have a funny situation, 1092 -- due to bugs or errors, we do not want to bomb). 1093 1094 elsif Is_Empty_Elmt_List (Call_List) then 1095 return; 1096 end if; 1097 1098 -- Here is the case where we detect recursion at compile time 1099 1100 -- Push our current scope for analyzing the declarations and code that 1101 -- we will insert for the checking. 1102 1103 Push_Scope (Spec); 1104 1105 -- This loop builds temporary variables for each of the referenced 1106 -- globals, so that at the end of the loop the list Shad_List contains 1107 -- these temporaries in one-to-one correspondence with the elements in 1108 -- Var_List. 1109 1110 Last := Empty; 1111 Elm := First_Elmt (Var_List); 1112 while Present (Elm) loop 1113 Var := Node (Elm); 1114 Ent := Make_Temporary (Loc, 'S'); 1115 Append_Elmt (Ent, Shad_List); 1116 1117 -- Insert a declaration for this temporary at the start of the 1118 -- declarations for the procedure. The temporaries are declared as 1119 -- constant objects initialized to the current values of the 1120 -- corresponding temporaries. 1121 1122 Decl := 1123 Make_Object_Declaration (Loc, 1124 Defining_Identifier => Ent, 1125 Object_Definition => New_Occurrence_Of (Etype (Var), Loc), 1126 Constant_Present => True, 1127 Expression => New_Occurrence_Of (Var, Loc)); 1128 1129 if No (Last) then 1130 Prepend (Decl, Declarations (N)); 1131 else 1132 Insert_After (Last, Decl); 1133 end if; 1134 1135 Last := Decl; 1136 Analyze (Decl); 1137 Next_Elmt (Elm); 1138 end loop; 1139 1140 -- Loop through calls 1141 1142 Call := First_Elmt (Call_List); 1143 while Present (Call) loop 1144 1145 -- Build a predicate expression of the form 1146 1147 -- True 1148 -- and then global1 = temp1 1149 -- and then global2 = temp2 1150 -- ... 1151 1152 -- This predicate determines if any of the global values 1153 -- referenced by the procedure have changed since the 1154 -- current call, if not an infinite recursion is assured. 1155 1156 Test := New_Occurrence_Of (Standard_True, Loc); 1157 1158 Elm1 := First_Elmt (Var_List); 1159 Elm2 := First_Elmt (Shad_List); 1160 while Present (Elm1) loop 1161 Test := 1162 Make_And_Then (Loc, 1163 Left_Opnd => Test, 1164 Right_Opnd => 1165 Make_Op_Eq (Loc, 1166 Left_Opnd => New_Occurrence_Of (Node (Elm1), Loc), 1167 Right_Opnd => New_Occurrence_Of (Node (Elm2), Loc))); 1168 1169 Next_Elmt (Elm1); 1170 Next_Elmt (Elm2); 1171 end loop; 1172 1173 -- Now we replace the call with the sequence 1174 1175 -- if no-changes (see above) then 1176 -- raise Storage_Error; 1177 -- else 1178 -- original-call 1179 -- end if; 1180 1181 Rewrite (Node (Call), 1182 Make_If_Statement (Loc, 1183 Condition => Test, 1184 Then_Statements => New_List ( 1185 Make_Raise_Storage_Error (Loc, 1186 Reason => SE_Infinite_Recursion)), 1187 1188 Else_Statements => New_List ( 1189 Relocate_Node (Node (Call))))); 1190 1191 Analyze (Node (Call)); 1192 1193 Next_Elmt (Call); 1194 end loop; 1195 1196 -- Remove temporary scope stack entry used for analysis 1197 1198 Pop_Scope; 1199 end Detect_Infinite_Recursion; 1200 1201 -------------------- 1202 -- Expand_Actuals -- 1203 -------------------- 1204 1205 procedure Expand_Actuals 1206 (N : Node_Id; 1207 Subp : Entity_Id; 1208 Post_Call : out List_Id) 1209 is 1210 Loc : constant Source_Ptr := Sloc (N); 1211 Actual : Node_Id; 1212 Formal : Entity_Id; 1213 N_Node : Node_Id; 1214 E_Actual : Entity_Id; 1215 E_Formal : Entity_Id; 1216 1217 procedure Add_Call_By_Copy_Code; 1218 -- For cases where the parameter must be passed by copy, this routine 1219 -- generates a temporary variable into which the actual is copied and 1220 -- then passes this as the parameter. For an OUT or IN OUT parameter, 1221 -- an assignment is also generated to copy the result back. The call 1222 -- also takes care of any constraint checks required for the type 1223 -- conversion case (on both the way in and the way out). 1224 1225 procedure Add_Simple_Call_By_Copy_Code; 1226 -- This is similar to the above, but is used in cases where we know 1227 -- that all that is needed is to simply create a temporary and copy 1228 -- the value in and out of the temporary. 1229 1230 procedure Add_Validation_Call_By_Copy_Code (Act : Node_Id); 1231 -- Perform copy-back for actual parameter Act which denotes a validation 1232 -- variable. 1233 1234 procedure Check_Fortran_Logical; 1235 -- A value of type Logical that is passed through a formal parameter 1236 -- must be normalized because .TRUE. usually does not have the same 1237 -- representation as True. We assume that .FALSE. = False = 0. 1238 -- What about functions that return a logical type ??? 1239 1240 function Is_Legal_Copy return Boolean; 1241 -- Check that an actual can be copied before generating the temporary 1242 -- to be used in the call. If the actual is of a by_reference type then 1243 -- the program is illegal (this can only happen in the presence of 1244 -- rep. clauses that force an incorrect alignment). If the formal is 1245 -- a by_reference parameter imposed by a DEC pragma, emit a warning to 1246 -- the effect that this might lead to unaligned arguments. 1247 1248 function Make_Var (Actual : Node_Id) return Entity_Id; 1249 -- Returns an entity that refers to the given actual parameter, Actual 1250 -- (not including any type conversion). If Actual is an entity name, 1251 -- then this entity is returned unchanged, otherwise a renaming is 1252 -- created to provide an entity for the actual. 1253 1254 procedure Reset_Packed_Prefix; 1255 -- The expansion of a packed array component reference is delayed in 1256 -- the context of a call. Now we need to complete the expansion, so we 1257 -- unmark the analyzed bits in all prefixes. 1258 1259 --------------------------- 1260 -- Add_Call_By_Copy_Code -- 1261 --------------------------- 1262 1263 procedure Add_Call_By_Copy_Code is 1264 Crep : Boolean; 1265 Expr : Node_Id; 1266 F_Typ : Entity_Id := Etype (Formal); 1267 Indic : Node_Id; 1268 Init : Node_Id; 1269 Temp : Entity_Id; 1270 V_Typ : Entity_Id; 1271 Var : Entity_Id; 1272 1273 begin 1274 if not Is_Legal_Copy then 1275 return; 1276 end if; 1277 1278 Temp := Make_Temporary (Loc, 'T', Actual); 1279 1280 -- Handle formals whose type comes from the limited view 1281 1282 if From_Limited_With (F_Typ) 1283 and then Has_Non_Limited_View (F_Typ) 1284 then 1285 F_Typ := Non_Limited_View (F_Typ); 1286 end if; 1287 1288 -- Use formal type for temp, unless formal type is an unconstrained 1289 -- array, in which case we don't have to worry about bounds checks, 1290 -- and we use the actual type, since that has appropriate bounds. 1291 1292 if Is_Array_Type (F_Typ) and then not Is_Constrained (F_Typ) then 1293 Indic := New_Occurrence_Of (Etype (Actual), Loc); 1294 else 1295 Indic := New_Occurrence_Of (F_Typ, Loc); 1296 end if; 1297 1298 if Nkind (Actual) = N_Type_Conversion then 1299 V_Typ := Etype (Expression (Actual)); 1300 1301 -- If the formal is an (in-)out parameter, capture the name 1302 -- of the variable in order to build the post-call assignment. 1303 1304 Var := Make_Var (Expression (Actual)); 1305 1306 Crep := not Same_Representation 1307 (F_Typ, Etype (Expression (Actual))); 1308 1309 else 1310 V_Typ := Etype (Actual); 1311 Var := Make_Var (Actual); 1312 Crep := False; 1313 end if; 1314 1315 -- Setup initialization for case of in out parameter, or an out 1316 -- parameter where the formal is an unconstrained array (in the 1317 -- latter case, we have to pass in an object with bounds). 1318 1319 -- If this is an out parameter, the initial copy is wasteful, so as 1320 -- an optimization for the one-dimensional case we extract the 1321 -- bounds of the actual and build an uninitialized temporary of the 1322 -- right size. 1323 1324 -- If the formal is an out parameter with discriminants, the 1325 -- discriminants must be captured even if the rest of the object 1326 -- is in principle uninitialized, because the discriminants may 1327 -- be read by the called subprogram. 1328 1329 if Ekind (Formal) = E_In_Out_Parameter 1330 or else (Is_Array_Type (F_Typ) and then not Is_Constrained (F_Typ)) 1331 or else Has_Discriminants (F_Typ) 1332 then 1333 if Nkind (Actual) = N_Type_Conversion then 1334 if Conversion_OK (Actual) then 1335 Init := OK_Convert_To (F_Typ, New_Occurrence_Of (Var, Loc)); 1336 else 1337 Init := Convert_To (F_Typ, New_Occurrence_Of (Var, Loc)); 1338 end if; 1339 1340 elsif Ekind (Formal) = E_Out_Parameter 1341 and then Is_Array_Type (F_Typ) 1342 and then Number_Dimensions (F_Typ) = 1 1343 and then not Has_Non_Null_Base_Init_Proc (F_Typ) 1344 then 1345 -- Actual is a one-dimensional array or slice, and the type 1346 -- requires no initialization. Create a temporary of the 1347 -- right size, but do not copy actual into it (optimization). 1348 1349 Init := Empty; 1350 Indic := 1351 Make_Subtype_Indication (Loc, 1352 Subtype_Mark => New_Occurrence_Of (F_Typ, Loc), 1353 Constraint => 1354 Make_Index_Or_Discriminant_Constraint (Loc, 1355 Constraints => New_List ( 1356 Make_Range (Loc, 1357 Low_Bound => 1358 Make_Attribute_Reference (Loc, 1359 Prefix => New_Occurrence_Of (Var, Loc), 1360 Attribute_Name => Name_First), 1361 High_Bound => 1362 Make_Attribute_Reference (Loc, 1363 Prefix => New_Occurrence_Of (Var, Loc), 1364 Attribute_Name => Name_Last))))); 1365 1366 else 1367 Init := New_Occurrence_Of (Var, Loc); 1368 end if; 1369 1370 -- An initialization is created for packed conversions as 1371 -- actuals for out parameters to enable Make_Object_Declaration 1372 -- to determine the proper subtype for N_Node. Note that this 1373 -- is wasteful because the extra copying on the call side is 1374 -- not required for such out parameters. ??? 1375 1376 elsif Ekind (Formal) = E_Out_Parameter 1377 and then Nkind (Actual) = N_Type_Conversion 1378 and then (Is_Bit_Packed_Array (F_Typ) 1379 or else 1380 Is_Bit_Packed_Array (Etype (Expression (Actual)))) 1381 then 1382 if Conversion_OK (Actual) then 1383 Init := OK_Convert_To (F_Typ, New_Occurrence_Of (Var, Loc)); 1384 else 1385 Init := Convert_To (F_Typ, New_Occurrence_Of (Var, Loc)); 1386 end if; 1387 1388 elsif Ekind (Formal) = E_In_Parameter then 1389 1390 -- Handle the case in which the actual is a type conversion 1391 1392 if Nkind (Actual) = N_Type_Conversion then 1393 if Conversion_OK (Actual) then 1394 Init := OK_Convert_To (F_Typ, New_Occurrence_Of (Var, Loc)); 1395 else 1396 Init := Convert_To (F_Typ, New_Occurrence_Of (Var, Loc)); 1397 end if; 1398 else 1399 Init := New_Occurrence_Of (Var, Loc); 1400 end if; 1401 1402 else 1403 Init := Empty; 1404 end if; 1405 1406 N_Node := 1407 Make_Object_Declaration (Loc, 1408 Defining_Identifier => Temp, 1409 Object_Definition => Indic, 1410 Expression => Init); 1411 Set_Assignment_OK (N_Node); 1412 Insert_Action (N, N_Node); 1413 1414 -- Now, normally the deal here is that we use the defining 1415 -- identifier created by that object declaration. There is 1416 -- one exception to this. In the change of representation case 1417 -- the above declaration will end up looking like: 1418 1419 -- temp : type := identifier; 1420 1421 -- And in this case we might as well use the identifier directly 1422 -- and eliminate the temporary. Note that the analysis of the 1423 -- declaration was not a waste of time in that case, since it is 1424 -- what generated the necessary change of representation code. If 1425 -- the change of representation introduced additional code, as in 1426 -- a fixed-integer conversion, the expression is not an identifier 1427 -- and must be kept. 1428 1429 if Crep 1430 and then Present (Expression (N_Node)) 1431 and then Is_Entity_Name (Expression (N_Node)) 1432 then 1433 Temp := Entity (Expression (N_Node)); 1434 Rewrite (N_Node, Make_Null_Statement (Loc)); 1435 end if; 1436 1437 -- For IN parameter, all we do is to replace the actual 1438 1439 if Ekind (Formal) = E_In_Parameter then 1440 Rewrite (Actual, New_Occurrence_Of (Temp, Loc)); 1441 Analyze (Actual); 1442 1443 -- Processing for OUT or IN OUT parameter 1444 1445 else 1446 -- Kill current value indications for the temporary variable we 1447 -- created, since we just passed it as an OUT parameter. 1448 1449 Kill_Current_Values (Temp); 1450 Set_Is_Known_Valid (Temp, False); 1451 Set_Is_True_Constant (Temp, False); 1452 1453 -- If type conversion, use reverse conversion on exit 1454 1455 if Nkind (Actual) = N_Type_Conversion then 1456 if Conversion_OK (Actual) then 1457 Expr := OK_Convert_To (V_Typ, New_Occurrence_Of (Temp, Loc)); 1458 else 1459 Expr := Convert_To (V_Typ, New_Occurrence_Of (Temp, Loc)); 1460 end if; 1461 else 1462 Expr := New_Occurrence_Of (Temp, Loc); 1463 end if; 1464 1465 Rewrite (Actual, New_Occurrence_Of (Temp, Loc)); 1466 Analyze (Actual); 1467 1468 -- If the actual is a conversion of a packed reference, it may 1469 -- already have been expanded by Remove_Side_Effects, and the 1470 -- resulting variable is a temporary which does not designate 1471 -- the proper out-parameter, which may not be addressable. In 1472 -- that case, generate an assignment to the original expression 1473 -- (before expansion of the packed reference) so that the proper 1474 -- expansion of assignment to a packed component can take place. 1475 1476 declare 1477 Obj : Node_Id; 1478 Lhs : Node_Id; 1479 1480 begin 1481 if Is_Renaming_Of_Object (Var) 1482 and then Nkind (Renamed_Object (Var)) = N_Selected_Component 1483 and then Nkind (Original_Node (Prefix (Renamed_Object (Var)))) 1484 = N_Indexed_Component 1485 and then 1486 Has_Non_Standard_Rep (Etype (Prefix (Renamed_Object (Var)))) 1487 then 1488 Obj := Renamed_Object (Var); 1489 Lhs := 1490 Make_Selected_Component (Loc, 1491 Prefix => 1492 New_Copy_Tree (Original_Node (Prefix (Obj))), 1493 Selector_Name => New_Copy (Selector_Name (Obj))); 1494 Reset_Analyzed_Flags (Lhs); 1495 1496 else 1497 Lhs := New_Occurrence_Of (Var, Loc); 1498 end if; 1499 1500 Set_Assignment_OK (Lhs); 1501 1502 if Is_Access_Type (E_Formal) 1503 and then Is_Entity_Name (Lhs) 1504 and then 1505 Present (Effective_Extra_Accessibility (Entity (Lhs))) 1506 then 1507 -- Copyback target is an Ada 2012 stand-alone object of an 1508 -- anonymous access type. 1509 1510 pragma Assert (Ada_Version >= Ada_2012); 1511 1512 if Type_Access_Level (E_Formal) > 1513 Object_Access_Level (Lhs) 1514 then 1515 Append_To (Post_Call, 1516 Make_Raise_Program_Error (Loc, 1517 Reason => PE_Accessibility_Check_Failed)); 1518 end if; 1519 1520 Append_To (Post_Call, 1521 Make_Assignment_Statement (Loc, 1522 Name => Lhs, 1523 Expression => Expr)); 1524 1525 -- We would like to somehow suppress generation of the 1526 -- extra_accessibility assignment generated by the expansion 1527 -- of the above assignment statement. It's not a correctness 1528 -- issue because the following assignment renders it dead, 1529 -- but generating back-to-back assignments to the same 1530 -- target is undesirable. ??? 1531 1532 Append_To (Post_Call, 1533 Make_Assignment_Statement (Loc, 1534 Name => New_Occurrence_Of ( 1535 Effective_Extra_Accessibility (Entity (Lhs)), Loc), 1536 Expression => Make_Integer_Literal (Loc, 1537 Type_Access_Level (E_Formal)))); 1538 1539 else 1540 Append_To (Post_Call, 1541 Make_Assignment_Statement (Loc, 1542 Name => Lhs, 1543 Expression => Expr)); 1544 end if; 1545 end; 1546 end if; 1547 end Add_Call_By_Copy_Code; 1548 1549 ---------------------------------- 1550 -- Add_Simple_Call_By_Copy_Code -- 1551 ---------------------------------- 1552 1553 procedure Add_Simple_Call_By_Copy_Code is 1554 Decl : Node_Id; 1555 F_Typ : Entity_Id := Etype (Formal); 1556 Incod : Node_Id; 1557 Indic : Node_Id; 1558 Lhs : Node_Id; 1559 Outcod : Node_Id; 1560 Rhs : Node_Id; 1561 Temp : Entity_Id; 1562 1563 begin 1564 if not Is_Legal_Copy then 1565 return; 1566 end if; 1567 1568 -- Handle formals whose type comes from the limited view 1569 1570 if From_Limited_With (F_Typ) 1571 and then Has_Non_Limited_View (F_Typ) 1572 then 1573 F_Typ := Non_Limited_View (F_Typ); 1574 end if; 1575 1576 -- Use formal type for temp, unless formal type is an unconstrained 1577 -- array, in which case we don't have to worry about bounds checks, 1578 -- and we use the actual type, since that has appropriate bounds. 1579 1580 if Is_Array_Type (F_Typ) and then not Is_Constrained (F_Typ) then 1581 Indic := New_Occurrence_Of (Etype (Actual), Loc); 1582 else 1583 Indic := New_Occurrence_Of (F_Typ, Loc); 1584 end if; 1585 1586 -- Prepare to generate code 1587 1588 Reset_Packed_Prefix; 1589 1590 Temp := Make_Temporary (Loc, 'T', Actual); 1591 Incod := Relocate_Node (Actual); 1592 Outcod := New_Copy_Tree (Incod); 1593 1594 -- Generate declaration of temporary variable, initializing it 1595 -- with the input parameter unless we have an OUT formal or 1596 -- this is an initialization call. 1597 1598 -- If the formal is an out parameter with discriminants, the 1599 -- discriminants must be captured even if the rest of the object 1600 -- is in principle uninitialized, because the discriminants may 1601 -- be read by the called subprogram. 1602 1603 if Ekind (Formal) = E_Out_Parameter then 1604 Incod := Empty; 1605 1606 if Has_Discriminants (F_Typ) then 1607 Indic := New_Occurrence_Of (Etype (Actual), Loc); 1608 end if; 1609 1610 elsif Inside_Init_Proc then 1611 1612 -- Could use a comment here to match comment below ??? 1613 1614 if Nkind (Actual) /= N_Selected_Component 1615 or else 1616 not Has_Discriminant_Dependent_Constraint 1617 (Entity (Selector_Name (Actual))) 1618 then 1619 Incod := Empty; 1620 1621 -- Otherwise, keep the component in order to generate the proper 1622 -- actual subtype, that depends on enclosing discriminants. 1623 1624 else 1625 null; 1626 end if; 1627 end if; 1628 1629 Decl := 1630 Make_Object_Declaration (Loc, 1631 Defining_Identifier => Temp, 1632 Object_Definition => Indic, 1633 Expression => Incod); 1634 1635 if Inside_Init_Proc 1636 and then No (Incod) 1637 then 1638 -- If the call is to initialize a component of a composite type, 1639 -- and the component does not depend on discriminants, use the 1640 -- actual type of the component. This is required in case the 1641 -- component is constrained, because in general the formal of the 1642 -- initialization procedure will be unconstrained. Note that if 1643 -- the component being initialized is constrained by an enclosing 1644 -- discriminant, the presence of the initialization in the 1645 -- declaration will generate an expression for the actual subtype. 1646 1647 Set_No_Initialization (Decl); 1648 Set_Object_Definition (Decl, 1649 New_Occurrence_Of (Etype (Actual), Loc)); 1650 end if; 1651 1652 Insert_Action (N, Decl); 1653 1654 -- The actual is simply a reference to the temporary 1655 1656 Rewrite (Actual, New_Occurrence_Of (Temp, Loc)); 1657 1658 -- Generate copy out if OUT or IN OUT parameter 1659 1660 if Ekind (Formal) /= E_In_Parameter then 1661 Lhs := Outcod; 1662 Rhs := New_Occurrence_Of (Temp, Loc); 1663 Set_Is_True_Constant (Temp, False); 1664 1665 -- Deal with conversion 1666 1667 if Nkind (Lhs) = N_Type_Conversion then 1668 Lhs := Expression (Lhs); 1669 Rhs := Convert_To (Etype (Actual), Rhs); 1670 end if; 1671 1672 Append_To (Post_Call, 1673 Make_Assignment_Statement (Loc, 1674 Name => Lhs, 1675 Expression => Rhs)); 1676 Set_Assignment_OK (Name (Last (Post_Call))); 1677 end if; 1678 end Add_Simple_Call_By_Copy_Code; 1679 1680 -------------------------------------- 1681 -- Add_Validation_Call_By_Copy_Code -- 1682 -------------------------------------- 1683 1684 procedure Add_Validation_Call_By_Copy_Code (Act : Node_Id) is 1685 Expr : Node_Id; 1686 Obj : Node_Id; 1687 Obj_Typ : Entity_Id; 1688 Var : constant Node_Id := Unqual_Conv (Act); 1689 Var_Id : Entity_Id; 1690 1691 begin 1692 -- Copy the value of the validation variable back into the object 1693 -- being validated. 1694 1695 if Is_Entity_Name (Var) then 1696 Var_Id := Entity (Var); 1697 Obj := Validated_Object (Var_Id); 1698 Obj_Typ := Etype (Obj); 1699 1700 Expr := New_Occurrence_Of (Var_Id, Loc); 1701 1702 -- A type conversion is needed when the validation variable and 1703 -- the validated object carry different types. This case occurs 1704 -- when the actual is qualified in some fashion. 1705 1706 -- Common: 1707 -- subtype Int is Integer range ...; 1708 -- procedure Call (Val : in out Integer); 1709 1710 -- Original: 1711 -- Object : Int; 1712 -- Call (Integer (Object)); 1713 1714 -- Expanded: 1715 -- Object : Int; 1716 -- Var : Integer := Object; -- conversion to base type 1717 -- if not Var'Valid then -- validity check 1718 -- Call (Var); -- modify Var 1719 -- Object := Int (Var); -- conversion to subtype 1720 1721 if Etype (Var_Id) /= Obj_Typ then 1722 Expr := 1723 Make_Type_Conversion (Loc, 1724 Subtype_Mark => New_Occurrence_Of (Obj_Typ, Loc), 1725 Expression => Expr); 1726 end if; 1727 1728 -- Generate: 1729 -- Object := Var; 1730 -- <or> 1731 -- Object := Object_Type (Var); 1732 1733 Append_To (Post_Call, 1734 Make_Assignment_Statement (Loc, 1735 Name => Obj, 1736 Expression => Expr)); 1737 1738 -- If the flow reaches this point, then this routine was invoked with 1739 -- an actual which does not denote a validation variable. 1740 1741 else 1742 pragma Assert (False); 1743 null; 1744 end if; 1745 end Add_Validation_Call_By_Copy_Code; 1746 1747 --------------------------- 1748 -- Check_Fortran_Logical -- 1749 --------------------------- 1750 1751 procedure Check_Fortran_Logical is 1752 Logical : constant Entity_Id := Etype (Formal); 1753 Var : Entity_Id; 1754 1755 -- Note: this is very incomplete, e.g. it does not handle arrays 1756 -- of logical values. This is really not the right approach at all???) 1757 1758 begin 1759 if Convention (Subp) = Convention_Fortran 1760 and then Root_Type (Etype (Formal)) = Standard_Boolean 1761 and then Ekind (Formal) /= E_In_Parameter 1762 then 1763 Var := Make_Var (Actual); 1764 Append_To (Post_Call, 1765 Make_Assignment_Statement (Loc, 1766 Name => New_Occurrence_Of (Var, Loc), 1767 Expression => 1768 Unchecked_Convert_To ( 1769 Logical, 1770 Make_Op_Ne (Loc, 1771 Left_Opnd => New_Occurrence_Of (Var, Loc), 1772 Right_Opnd => 1773 Unchecked_Convert_To ( 1774 Logical, 1775 New_Occurrence_Of (Standard_False, Loc)))))); 1776 end if; 1777 end Check_Fortran_Logical; 1778 1779 ------------------- 1780 -- Is_Legal_Copy -- 1781 ------------------- 1782 1783 function Is_Legal_Copy return Boolean is 1784 begin 1785 -- An attempt to copy a value of such a type can only occur if 1786 -- representation clauses give the actual a misaligned address. 1787 1788 if Is_By_Reference_Type (Etype (Formal)) then 1789 1790 -- The actual may in fact be properly aligned but there is not 1791 -- enough front-end information to determine this. In that case 1792 -- gigi will emit an error if a copy is not legal, or generate 1793 -- the proper code. 1794 1795 return False; 1796 1797 -- For users of Starlet, we assume that the specification of by- 1798 -- reference mechanism is mandatory. This may lead to unaligned 1799 -- objects but at least for DEC legacy code it is known to work. 1800 -- The warning will alert users of this code that a problem may 1801 -- be lurking. 1802 1803 elsif Mechanism (Formal) = By_Reference 1804 and then Is_Valued_Procedure (Scope (Formal)) 1805 then 1806 Error_Msg_N 1807 ("by_reference actual may be misaligned??", Actual); 1808 return False; 1809 1810 else 1811 return True; 1812 end if; 1813 end Is_Legal_Copy; 1814 1815 -------------- 1816 -- Make_Var -- 1817 -------------- 1818 1819 function Make_Var (Actual : Node_Id) return Entity_Id is 1820 Var : Entity_Id; 1821 1822 begin 1823 if Is_Entity_Name (Actual) then 1824 return Entity (Actual); 1825 1826 else 1827 Var := Make_Temporary (Loc, 'T', Actual); 1828 1829 N_Node := 1830 Make_Object_Renaming_Declaration (Loc, 1831 Defining_Identifier => Var, 1832 Subtype_Mark => 1833 New_Occurrence_Of (Etype (Actual), Loc), 1834 Name => Relocate_Node (Actual)); 1835 1836 Insert_Action (N, N_Node); 1837 return Var; 1838 end if; 1839 end Make_Var; 1840 1841 ------------------------- 1842 -- Reset_Packed_Prefix -- 1843 ------------------------- 1844 1845 procedure Reset_Packed_Prefix is 1846 Pfx : Node_Id := Actual; 1847 begin 1848 loop 1849 Set_Analyzed (Pfx, False); 1850 exit when 1851 not Nkind_In (Pfx, N_Selected_Component, N_Indexed_Component); 1852 Pfx := Prefix (Pfx); 1853 end loop; 1854 end Reset_Packed_Prefix; 1855 1856 -- Start of processing for Expand_Actuals 1857 1858 begin 1859 Post_Call := New_List; 1860 1861 Formal := First_Formal (Subp); 1862 Actual := First_Actual (N); 1863 while Present (Formal) loop 1864 E_Formal := Etype (Formal); 1865 E_Actual := Etype (Actual); 1866 1867 -- Handle formals whose type comes from the limited view 1868 1869 if From_Limited_With (E_Formal) 1870 and then Has_Non_Limited_View (E_Formal) 1871 then 1872 E_Formal := Non_Limited_View (E_Formal); 1873 end if; 1874 1875 if Is_Scalar_Type (E_Formal) 1876 or else Nkind (Actual) = N_Slice 1877 then 1878 Check_Fortran_Logical; 1879 1880 -- RM 6.4.1 (11) 1881 1882 elsif Ekind (Formal) /= E_Out_Parameter then 1883 1884 -- The unusual case of the current instance of a protected type 1885 -- requires special handling. This can only occur in the context 1886 -- of a call within the body of a protected operation. 1887 1888 if Is_Entity_Name (Actual) 1889 and then Ekind (Entity (Actual)) = E_Protected_Type 1890 and then In_Open_Scopes (Entity (Actual)) 1891 then 1892 if Scope (Subp) /= Entity (Actual) then 1893 Error_Msg_N 1894 ("operation outside protected type may not " 1895 & "call back its protected operations??", Actual); 1896 end if; 1897 1898 Rewrite (Actual, 1899 Expand_Protected_Object_Reference (N, Entity (Actual))); 1900 end if; 1901 1902 -- Ada 2005 (AI-318-02): If the actual parameter is a call to a 1903 -- build-in-place function, then a temporary return object needs 1904 -- to be created and access to it must be passed to the function. 1905 -- Currently we limit such functions to those with inherently 1906 -- limited result subtypes, but eventually we plan to expand the 1907 -- functions that are treated as build-in-place to include other 1908 -- composite result types. 1909 1910 if Is_Build_In_Place_Function_Call (Actual) then 1911 Make_Build_In_Place_Call_In_Anonymous_Context (Actual); 1912 1913 -- Ada 2005 (AI-318-02): Specialization of the previous case for 1914 -- actuals containing build-in-place function calls whose returned 1915 -- object covers interface types. 1916 1917 elsif Present (Unqual_BIP_Iface_Function_Call (Actual)) then 1918 Make_Build_In_Place_Iface_Call_In_Anonymous_Context (Actual); 1919 end if; 1920 1921 Apply_Constraint_Check (Actual, E_Formal); 1922 1923 -- Out parameter case. No constraint checks on access type 1924 -- RM 6.4.1 (13) 1925 1926 elsif Is_Access_Type (E_Formal) then 1927 null; 1928 1929 -- RM 6.4.1 (14) 1930 1931 elsif Has_Discriminants (Base_Type (E_Formal)) 1932 or else Has_Non_Null_Base_Init_Proc (E_Formal) 1933 then 1934 Apply_Constraint_Check (Actual, E_Formal); 1935 1936 -- RM 6.4.1 (15) 1937 1938 else 1939 Apply_Constraint_Check (Actual, Base_Type (E_Formal)); 1940 end if; 1941 1942 -- Processing for IN-OUT and OUT parameters 1943 1944 if Ekind (Formal) /= E_In_Parameter then 1945 1946 -- For type conversions of arrays, apply length/range checks 1947 1948 if Is_Array_Type (E_Formal) 1949 and then Nkind (Actual) = N_Type_Conversion 1950 then 1951 if Is_Constrained (E_Formal) then 1952 Apply_Length_Check (Expression (Actual), E_Formal); 1953 else 1954 Apply_Range_Check (Expression (Actual), E_Formal); 1955 end if; 1956 end if; 1957 1958 -- The actual denotes a variable which captures the value of an 1959 -- object for validation purposes. Add a copy-back to reflect any 1960 -- potential changes in value back into the original object. 1961 1962 -- Var : ... := Object; 1963 -- if not Var'Valid then -- validity check 1964 -- Call (Var); -- modify var 1965 -- Object := Var; -- update Object 1966 1967 -- This case is given higher priority because the subsequent check 1968 -- for type conversion may add an extra copy of the variable and 1969 -- prevent proper value propagation back in the original object. 1970 1971 if Is_Validation_Variable_Reference (Actual) then 1972 Add_Validation_Call_By_Copy_Code (Actual); 1973 1974 -- If argument is a type conversion for a type that is passed by 1975 -- copy, then we must pass the parameter by copy. 1976 1977 elsif Nkind (Actual) = N_Type_Conversion 1978 and then 1979 (Is_Numeric_Type (E_Formal) 1980 or else Is_Access_Type (E_Formal) 1981 or else Is_Enumeration_Type (E_Formal) 1982 or else Is_Bit_Packed_Array (Etype (Formal)) 1983 or else Is_Bit_Packed_Array (Etype (Expression (Actual))) 1984 1985 -- Also pass by copy if change of representation 1986 1987 or else not Same_Representation 1988 (Etype (Formal), 1989 Etype (Expression (Actual)))) 1990 then 1991 Add_Call_By_Copy_Code; 1992 1993 -- References to components of bit-packed arrays are expanded 1994 -- at this point, rather than at the point of analysis of the 1995 -- actuals, to handle the expansion of the assignment to 1996 -- [in] out parameters. 1997 1998 elsif Is_Ref_To_Bit_Packed_Array (Actual) then 1999 Add_Simple_Call_By_Copy_Code; 2000 2001 -- If a non-scalar actual is possibly bit-aligned, we need a copy 2002 -- because the back-end cannot cope with such objects. In other 2003 -- cases where alignment forces a copy, the back-end generates 2004 -- it properly. It should not be generated unconditionally in the 2005 -- front-end because it does not know precisely the alignment 2006 -- requirements of the target, and makes too conservative an 2007 -- estimate, leading to superfluous copies or spurious errors 2008 -- on by-reference parameters. 2009 2010 elsif Nkind (Actual) = N_Selected_Component 2011 and then 2012 Component_May_Be_Bit_Aligned (Entity (Selector_Name (Actual))) 2013 and then not Represented_As_Scalar (Etype (Formal)) 2014 then 2015 Add_Simple_Call_By_Copy_Code; 2016 2017 -- References to slices of bit-packed arrays are expanded 2018 2019 elsif Is_Ref_To_Bit_Packed_Slice (Actual) then 2020 Add_Call_By_Copy_Code; 2021 2022 -- References to possibly unaligned slices of arrays are expanded 2023 2024 elsif Is_Possibly_Unaligned_Slice (Actual) then 2025 Add_Call_By_Copy_Code; 2026 2027 -- Deal with access types where the actual subtype and the 2028 -- formal subtype are not the same, requiring a check. 2029 2030 -- It is necessary to exclude tagged types because of "downward 2031 -- conversion" errors. 2032 2033 elsif Is_Access_Type (E_Formal) 2034 and then not Same_Type (E_Formal, E_Actual) 2035 and then not Is_Tagged_Type (Designated_Type (E_Formal)) 2036 then 2037 Add_Call_By_Copy_Code; 2038 2039 -- If the actual is not a scalar and is marked for volatile 2040 -- treatment, whereas the formal is not volatile, then pass 2041 -- by copy unless it is a by-reference type. 2042 2043 -- Note: we use Is_Volatile here rather than Treat_As_Volatile, 2044 -- because this is the enforcement of a language rule that applies 2045 -- only to "real" volatile variables, not e.g. to the address 2046 -- clause overlay case. 2047 2048 elsif Is_Entity_Name (Actual) 2049 and then Is_Volatile (Entity (Actual)) 2050 and then not Is_By_Reference_Type (E_Actual) 2051 and then not Is_Scalar_Type (Etype (Entity (Actual))) 2052 and then not Is_Volatile (E_Formal) 2053 then 2054 Add_Call_By_Copy_Code; 2055 2056 elsif Nkind (Actual) = N_Indexed_Component 2057 and then Is_Entity_Name (Prefix (Actual)) 2058 and then Has_Volatile_Components (Entity (Prefix (Actual))) 2059 then 2060 Add_Call_By_Copy_Code; 2061 2062 -- Add call-by-copy code for the case of scalar out parameters 2063 -- when it is not known at compile time that the subtype of the 2064 -- formal is a subrange of the subtype of the actual (or vice 2065 -- versa for in out parameters), in order to get range checks 2066 -- on such actuals. (Maybe this case should be handled earlier 2067 -- in the if statement???) 2068 2069 elsif Is_Scalar_Type (E_Formal) 2070 and then 2071 (not In_Subrange_Of (E_Formal, E_Actual) 2072 or else 2073 (Ekind (Formal) = E_In_Out_Parameter 2074 and then not In_Subrange_Of (E_Actual, E_Formal))) 2075 then 2076 -- Perhaps the setting back to False should be done within 2077 -- Add_Call_By_Copy_Code, since it could get set on other 2078 -- cases occurring above??? 2079 2080 if Do_Range_Check (Actual) then 2081 Set_Do_Range_Check (Actual, False); 2082 end if; 2083 2084 Add_Call_By_Copy_Code; 2085 end if; 2086 2087 -- RM 3.2.4 (23/3): A predicate is checked on in-out and out 2088 -- by-reference parameters on exit from the call. If the actual 2089 -- is a derived type and the operation is inherited, the body 2090 -- of the operation will not contain a call to the predicate 2091 -- function, so it must be done explicitly after the call. Ditto 2092 -- if the actual is an entity of a predicated subtype. 2093 2094 -- The rule refers to by-reference types, but a check is needed 2095 -- for by-copy types as well. That check is subsumed by the rule 2096 -- for subtype conversion on assignment, but we can generate the 2097 -- required check now. 2098 2099 -- Note also that Subp may be either a subprogram entity for 2100 -- direct calls, or a type entity for indirect calls, which must 2101 -- be handled separately because the name does not denote an 2102 -- overloadable entity. 2103 2104 By_Ref_Predicate_Check : declare 2105 Aund : constant Entity_Id := Underlying_Type (E_Actual); 2106 Atyp : Entity_Id; 2107 2108 function Is_Public_Subp return Boolean; 2109 -- Check whether the subprogram being called is a visible 2110 -- operation of the type of the actual. Used to determine 2111 -- whether an invariant check must be generated on the 2112 -- caller side. 2113 2114 --------------------- 2115 -- Is_Public_Subp -- 2116 --------------------- 2117 2118 function Is_Public_Subp return Boolean is 2119 Pack : constant Entity_Id := Scope (Subp); 2120 Subp_Decl : Node_Id; 2121 2122 begin 2123 if not Is_Subprogram (Subp) then 2124 return False; 2125 2126 -- The operation may be inherited, or a primitive of the 2127 -- root type. 2128 2129 elsif 2130 Nkind_In (Parent (Subp), N_Private_Extension_Declaration, 2131 N_Full_Type_Declaration) 2132 then 2133 Subp_Decl := Parent (Subp); 2134 2135 else 2136 Subp_Decl := Unit_Declaration_Node (Subp); 2137 end if; 2138 2139 return Ekind (Pack) = E_Package 2140 and then 2141 List_Containing (Subp_Decl) = 2142 Visible_Declarations 2143 (Specification (Unit_Declaration_Node (Pack))); 2144 end Is_Public_Subp; 2145 2146 -- Start of processing for By_Ref_Predicate_Check 2147 2148 begin 2149 if No (Aund) then 2150 Atyp := E_Actual; 2151 else 2152 Atyp := Aund; 2153 end if; 2154 2155 if Has_Predicates (Atyp) 2156 and then Present (Predicate_Function (Atyp)) 2157 2158 -- Skip predicate checks for special cases 2159 2160 and then Predicate_Tests_On_Arguments (Subp) 2161 then 2162 Append_To (Post_Call, 2163 Make_Predicate_Check (Atyp, Actual)); 2164 end if; 2165 2166 -- We generated caller-side invariant checks in two cases: 2167 2168 -- a) when calling an inherited operation, where there is an 2169 -- implicit view conversion of the actual to the parent type. 2170 2171 -- b) When the conversion is explicit 2172 2173 -- We treat these cases separately because the required 2174 -- conversion for a) is added later when expanding the call. 2175 2176 if Has_Invariants (Etype (Actual)) 2177 and then 2178 Nkind (Parent (Subp)) = N_Private_Extension_Declaration 2179 then 2180 if Comes_From_Source (N) and then Is_Public_Subp then 2181 Append_To (Post_Call, Make_Invariant_Call (Actual)); 2182 end if; 2183 2184 elsif Nkind (Actual) = N_Type_Conversion 2185 and then Has_Invariants (Etype (Expression (Actual))) 2186 then 2187 if Comes_From_Source (N) and then Is_Public_Subp then 2188 Append_To (Post_Call, 2189 Make_Invariant_Call (Expression (Actual))); 2190 end if; 2191 end if; 2192 end By_Ref_Predicate_Check; 2193 2194 -- Processing for IN parameters 2195 2196 else 2197 -- For IN parameters in the bit-packed array case, we expand an 2198 -- indexed component (the circuit in Exp_Ch4 deliberately left 2199 -- indexed components appearing as actuals untouched, so that 2200 -- the special processing above for the OUT and IN OUT cases 2201 -- could be performed. We could make the test in Exp_Ch4 more 2202 -- complex and have it detect the parameter mode, but it is 2203 -- easier simply to handle all cases here.) 2204 2205 if Nkind (Actual) = N_Indexed_Component 2206 and then Is_Bit_Packed_Array (Etype (Prefix (Actual))) 2207 then 2208 Reset_Packed_Prefix; 2209 Expand_Packed_Element_Reference (Actual); 2210 2211 -- If we have a reference to a bit-packed array, we copy it, since 2212 -- the actual must be byte aligned. 2213 2214 -- Is this really necessary in all cases??? 2215 2216 elsif Is_Ref_To_Bit_Packed_Array (Actual) then 2217 Add_Simple_Call_By_Copy_Code; 2218 2219 -- If a non-scalar actual is possibly unaligned, we need a copy 2220 2221 elsif Is_Possibly_Unaligned_Object (Actual) 2222 and then not Represented_As_Scalar (Etype (Formal)) 2223 then 2224 Add_Simple_Call_By_Copy_Code; 2225 2226 -- Similarly, we have to expand slices of packed arrays here 2227 -- because the result must be byte aligned. 2228 2229 elsif Is_Ref_To_Bit_Packed_Slice (Actual) then 2230 Add_Call_By_Copy_Code; 2231 2232 -- Only processing remaining is to pass by copy if this is a 2233 -- reference to a possibly unaligned slice, since the caller 2234 -- expects an appropriately aligned argument. 2235 2236 elsif Is_Possibly_Unaligned_Slice (Actual) then 2237 Add_Call_By_Copy_Code; 2238 2239 -- An unusual case: a current instance of an enclosing task can be 2240 -- an actual, and must be replaced by a reference to self. 2241 2242 elsif Is_Entity_Name (Actual) 2243 and then Is_Task_Type (Entity (Actual)) 2244 then 2245 if In_Open_Scopes (Entity (Actual)) then 2246 Rewrite (Actual, 2247 (Make_Function_Call (Loc, 2248 Name => New_Occurrence_Of (RTE (RE_Self), Loc)))); 2249 Analyze (Actual); 2250 2251 -- A task type cannot otherwise appear as an actual 2252 2253 else 2254 raise Program_Error; 2255 end if; 2256 end if; 2257 end if; 2258 2259 Next_Formal (Formal); 2260 Next_Actual (Actual); 2261 end loop; 2262 end Expand_Actuals; 2263 2264 ----------------- 2265 -- Expand_Call -- 2266 ----------------- 2267 2268 procedure Expand_Call (N : Node_Id) is 2269 Post_Call : List_Id; 2270 2271 begin 2272 pragma Assert (Nkind_In (N, N_Entry_Call_Statement, 2273 N_Function_Call, 2274 N_Procedure_Call_Statement)); 2275 2276 Expand_Call_Helper (N, Post_Call); 2277 Insert_Post_Call_Actions (N, Post_Call); 2278 end Expand_Call; 2279 2280 ------------------------ 2281 -- Expand_Call_Helper -- 2282 ------------------------ 2283 2284 -- This procedure handles expansion of function calls and procedure call 2285 -- statements (i.e. it serves as the body for Expand_N_Function_Call and 2286 -- Expand_N_Procedure_Call_Statement). Processing for calls includes: 2287 2288 -- Replace call to Raise_Exception by Raise_Exception_Always if possible 2289 -- Provide values of actuals for all formals in Extra_Formals list 2290 -- Replace "call" to enumeration literal function by literal itself 2291 -- Rewrite call to predefined operator as operator 2292 -- Replace actuals to in-out parameters that are numeric conversions, 2293 -- with explicit assignment to temporaries before and after the call. 2294 2295 -- Note that the list of actuals has been filled with default expressions 2296 -- during semantic analysis of the call. Only the extra actuals required 2297 -- for the 'Constrained attribute and for accessibility checks are added 2298 -- at this point. 2299 2300 procedure Expand_Call_Helper (N : Node_Id; Post_Call : out List_Id) is 2301 Loc : constant Source_Ptr := Sloc (N); 2302 Call_Node : Node_Id := N; 2303 Extra_Actuals : List_Id := No_List; 2304 Prev : Node_Id := Empty; 2305 2306 procedure Add_Actual_Parameter (Insert_Param : Node_Id); 2307 -- Adds one entry to the end of the actual parameter list. Used for 2308 -- default parameters and for extra actuals (for Extra_Formals). The 2309 -- argument is an N_Parameter_Association node. 2310 2311 procedure Add_Extra_Actual (Expr : Node_Id; EF : Entity_Id); 2312 -- Adds an extra actual to the list of extra actuals. Expr is the 2313 -- expression for the value of the actual, EF is the entity for the 2314 -- extra formal. 2315 2316 procedure Add_View_Conversion_Invariants 2317 (Formal : Entity_Id; 2318 Actual : Node_Id); 2319 -- Adds invariant checks for every intermediate type between the range 2320 -- of a view converted argument to its ancestor (from parent to child). 2321 2322 function Inherited_From_Formal (S : Entity_Id) return Entity_Id; 2323 -- Within an instance, a type derived from an untagged formal derived 2324 -- type inherits from the original parent, not from the actual. The 2325 -- current derivation mechanism has the derived type inherit from the 2326 -- actual, which is only correct outside of the instance. If the 2327 -- subprogram is inherited, we test for this particular case through a 2328 -- convoluted tree traversal before setting the proper subprogram to be 2329 -- called. 2330 2331 function In_Unfrozen_Instance (E : Entity_Id) return Boolean; 2332 -- Return true if E comes from an instance that is not yet frozen 2333 2334 function Is_Direct_Deep_Call (Subp : Entity_Id) return Boolean; 2335 -- Determine if Subp denotes a non-dispatching call to a Deep routine 2336 2337 function New_Value (From : Node_Id) return Node_Id; 2338 -- From is the original Expression. New_Value is equivalent to a call 2339 -- to Duplicate_Subexpr with an explicit dereference when From is an 2340 -- access parameter. 2341 2342 -------------------------- 2343 -- Add_Actual_Parameter -- 2344 -------------------------- 2345 2346 procedure Add_Actual_Parameter (Insert_Param : Node_Id) is 2347 Actual_Expr : constant Node_Id := 2348 Explicit_Actual_Parameter (Insert_Param); 2349 2350 begin 2351 -- Case of insertion is first named actual 2352 2353 if No (Prev) or else 2354 Nkind (Parent (Prev)) /= N_Parameter_Association 2355 then 2356 Set_Next_Named_Actual 2357 (Insert_Param, First_Named_Actual (Call_Node)); 2358 Set_First_Named_Actual (Call_Node, Actual_Expr); 2359 2360 if No (Prev) then 2361 if No (Parameter_Associations (Call_Node)) then 2362 Set_Parameter_Associations (Call_Node, New_List); 2363 end if; 2364 2365 Append (Insert_Param, Parameter_Associations (Call_Node)); 2366 2367 else 2368 Insert_After (Prev, Insert_Param); 2369 end if; 2370 2371 -- Case of insertion is not first named actual 2372 2373 else 2374 Set_Next_Named_Actual 2375 (Insert_Param, Next_Named_Actual (Parent (Prev))); 2376 Set_Next_Named_Actual (Parent (Prev), Actual_Expr); 2377 Append (Insert_Param, Parameter_Associations (Call_Node)); 2378 end if; 2379 2380 Prev := Actual_Expr; 2381 end Add_Actual_Parameter; 2382 2383 ---------------------- 2384 -- Add_Extra_Actual -- 2385 ---------------------- 2386 2387 procedure Add_Extra_Actual (Expr : Node_Id; EF : Entity_Id) is 2388 Loc : constant Source_Ptr := Sloc (Expr); 2389 2390 begin 2391 if Extra_Actuals = No_List then 2392 Extra_Actuals := New_List; 2393 Set_Parent (Extra_Actuals, Call_Node); 2394 end if; 2395 2396 Append_To (Extra_Actuals, 2397 Make_Parameter_Association (Loc, 2398 Selector_Name => New_Occurrence_Of (EF, Loc), 2399 Explicit_Actual_Parameter => Expr)); 2400 2401 Analyze_And_Resolve (Expr, Etype (EF)); 2402 2403 if Nkind (Call_Node) = N_Function_Call then 2404 Set_Is_Accessibility_Actual (Parent (Expr)); 2405 end if; 2406 end Add_Extra_Actual; 2407 2408 ------------------------------------ 2409 -- Add_View_Conversion_Invariants -- 2410 ------------------------------------ 2411 2412 procedure Add_View_Conversion_Invariants 2413 (Formal : Entity_Id; 2414 Actual : Node_Id) 2415 is 2416 Arg : Entity_Id; 2417 Curr_Typ : Entity_Id; 2418 Inv_Checks : List_Id; 2419 Par_Typ : Entity_Id; 2420 2421 begin 2422 Inv_Checks := No_List; 2423 2424 -- Extract the argument from a potentially nested set of view 2425 -- conversions. 2426 2427 Arg := Actual; 2428 while Nkind (Arg) = N_Type_Conversion loop 2429 Arg := Expression (Arg); 2430 end loop; 2431 2432 -- Move up the derivation chain starting with the type of the formal 2433 -- parameter down to the type of the actual object. 2434 2435 Curr_Typ := Empty; 2436 Par_Typ := Etype (Arg); 2437 while Par_Typ /= Etype (Formal) and Par_Typ /= Curr_Typ loop 2438 Curr_Typ := Par_Typ; 2439 2440 if Has_Invariants (Curr_Typ) 2441 and then Present (Invariant_Procedure (Curr_Typ)) 2442 then 2443 -- Verify the invariate of the current type. Generate: 2444 2445 -- <Curr_Typ>Invariant (Curr_Typ (Arg)); 2446 2447 Prepend_New_To (Inv_Checks, 2448 Make_Procedure_Call_Statement (Loc, 2449 Name => 2450 New_Occurrence_Of 2451 (Invariant_Procedure (Curr_Typ), Loc), 2452 Parameter_Associations => New_List ( 2453 Make_Type_Conversion (Loc, 2454 Subtype_Mark => New_Occurrence_Of (Curr_Typ, Loc), 2455 Expression => New_Copy_Tree (Arg))))); 2456 end if; 2457 2458 Par_Typ := Base_Type (Etype (Curr_Typ)); 2459 end loop; 2460 2461 if not Is_Empty_List (Inv_Checks) then 2462 Insert_Actions_After (N, Inv_Checks); 2463 end if; 2464 end Add_View_Conversion_Invariants; 2465 2466 --------------------------- 2467 -- Inherited_From_Formal -- 2468 --------------------------- 2469 2470 function Inherited_From_Formal (S : Entity_Id) return Entity_Id is 2471 Par : Entity_Id; 2472 Gen_Par : Entity_Id; 2473 Gen_Prim : Elist_Id; 2474 Elmt : Elmt_Id; 2475 Indic : Node_Id; 2476 2477 begin 2478 -- If the operation is inherited, it is attached to the corresponding 2479 -- type derivation. If the parent in the derivation is a generic 2480 -- actual, it is a subtype of the actual, and we have to recover the 2481 -- original derived type declaration to find the proper parent. 2482 2483 if Nkind (Parent (S)) /= N_Full_Type_Declaration 2484 or else not Is_Derived_Type (Defining_Identifier (Parent (S))) 2485 or else Nkind (Type_Definition (Original_Node (Parent (S)))) /= 2486 N_Derived_Type_Definition 2487 or else not In_Instance 2488 then 2489 return Empty; 2490 2491 else 2492 Indic := 2493 Subtype_Indication 2494 (Type_Definition (Original_Node (Parent (S)))); 2495 2496 if Nkind (Indic) = N_Subtype_Indication then 2497 Par := Entity (Subtype_Mark (Indic)); 2498 else 2499 Par := Entity (Indic); 2500 end if; 2501 end if; 2502 2503 if not Is_Generic_Actual_Type (Par) 2504 or else Is_Tagged_Type (Par) 2505 or else Nkind (Parent (Par)) /= N_Subtype_Declaration 2506 or else not In_Open_Scopes (Scope (Par)) 2507 then 2508 return Empty; 2509 else 2510 Gen_Par := Generic_Parent_Type (Parent (Par)); 2511 end if; 2512 2513 -- If the actual has no generic parent type, the formal is not 2514 -- a formal derived type, so nothing to inherit. 2515 2516 if No (Gen_Par) then 2517 return Empty; 2518 end if; 2519 2520 -- If the generic parent type is still the generic type, this is a 2521 -- private formal, not a derived formal, and there are no operations 2522 -- inherited from the formal. 2523 2524 if Nkind (Parent (Gen_Par)) = N_Formal_Type_Declaration then 2525 return Empty; 2526 end if; 2527 2528 Gen_Prim := Collect_Primitive_Operations (Gen_Par); 2529 2530 Elmt := First_Elmt (Gen_Prim); 2531 while Present (Elmt) loop 2532 if Chars (Node (Elmt)) = Chars (S) then 2533 declare 2534 F1 : Entity_Id; 2535 F2 : Entity_Id; 2536 2537 begin 2538 F1 := First_Formal (S); 2539 F2 := First_Formal (Node (Elmt)); 2540 while Present (F1) 2541 and then Present (F2) 2542 loop 2543 if Etype (F1) = Etype (F2) 2544 or else Etype (F2) = Gen_Par 2545 then 2546 Next_Formal (F1); 2547 Next_Formal (F2); 2548 else 2549 Next_Elmt (Elmt); 2550 exit; -- not the right subprogram 2551 end if; 2552 2553 return Node (Elmt); 2554 end loop; 2555 end; 2556 2557 else 2558 Next_Elmt (Elmt); 2559 end if; 2560 end loop; 2561 2562 raise Program_Error; 2563 end Inherited_From_Formal; 2564 2565 -------------------------- 2566 -- In_Unfrozen_Instance -- 2567 -------------------------- 2568 2569 function In_Unfrozen_Instance (E : Entity_Id) return Boolean is 2570 S : Entity_Id; 2571 2572 begin 2573 S := E; 2574 while Present (S) and then S /= Standard_Standard loop 2575 if Is_Generic_Instance (S) 2576 and then Present (Freeze_Node (S)) 2577 and then not Analyzed (Freeze_Node (S)) 2578 then 2579 return True; 2580 end if; 2581 2582 S := Scope (S); 2583 end loop; 2584 2585 return False; 2586 end In_Unfrozen_Instance; 2587 2588 ------------------------- 2589 -- Is_Direct_Deep_Call -- 2590 ------------------------- 2591 2592 function Is_Direct_Deep_Call (Subp : Entity_Id) return Boolean is 2593 begin 2594 if Is_TSS (Subp, TSS_Deep_Adjust) 2595 or else Is_TSS (Subp, TSS_Deep_Finalize) 2596 or else Is_TSS (Subp, TSS_Deep_Initialize) 2597 then 2598 declare 2599 Actual : Node_Id; 2600 Formal : Node_Id; 2601 2602 begin 2603 Actual := First (Parameter_Associations (N)); 2604 Formal := First_Formal (Subp); 2605 while Present (Actual) 2606 and then Present (Formal) 2607 loop 2608 if Nkind (Actual) = N_Identifier 2609 and then Is_Controlling_Actual (Actual) 2610 and then Etype (Actual) = Etype (Formal) 2611 then 2612 return True; 2613 end if; 2614 2615 Next (Actual); 2616 Next_Formal (Formal); 2617 end loop; 2618 end; 2619 end if; 2620 2621 return False; 2622 end Is_Direct_Deep_Call; 2623 2624 --------------- 2625 -- New_Value -- 2626 --------------- 2627 2628 function New_Value (From : Node_Id) return Node_Id is 2629 Res : constant Node_Id := Duplicate_Subexpr (From); 2630 begin 2631 if Is_Access_Type (Etype (From)) then 2632 return Make_Explicit_Dereference (Sloc (From), Prefix => Res); 2633 else 2634 return Res; 2635 end if; 2636 end New_Value; 2637 2638 -- Local variables 2639 2640 Remote : constant Boolean := Is_Remote_Call (Call_Node); 2641 Actual : Node_Id; 2642 Formal : Entity_Id; 2643 Orig_Subp : Entity_Id := Empty; 2644 Param_Count : Natural := 0; 2645 Parent_Formal : Entity_Id; 2646 Parent_Subp : Entity_Id; 2647 Pref_Entity : Entity_Id; 2648 Scop : Entity_Id; 2649 Subp : Entity_Id; 2650 2651 Prev_Orig : Node_Id; 2652 -- Original node for an actual, which may have been rewritten. If the 2653 -- actual is a function call that has been transformed from a selected 2654 -- component, the original node is unanalyzed. Otherwise, it carries 2655 -- semantic information used to generate additional actuals. 2656 2657 CW_Interface_Formals_Present : Boolean := False; 2658 2659 -- Start of processing for Expand_Call_Helper 2660 2661 begin 2662 Post_Call := New_List; 2663 2664 -- Expand the function or procedure call if the first actual has a 2665 -- declared dimension aspect, and the subprogram is declared in one 2666 -- of the dimension I/O packages. 2667 2668 if Ada_Version >= Ada_2012 2669 and then 2670 Nkind_In (Call_Node, N_Procedure_Call_Statement, N_Function_Call) 2671 and then Present (Parameter_Associations (Call_Node)) 2672 then 2673 Expand_Put_Call_With_Symbol (Call_Node); 2674 end if; 2675 2676 -- Ignore if previous error 2677 2678 if Nkind (Call_Node) in N_Has_Etype 2679 and then Etype (Call_Node) = Any_Type 2680 then 2681 return; 2682 end if; 2683 2684 -- Call using access to subprogram with explicit dereference 2685 2686 if Nkind (Name (Call_Node)) = N_Explicit_Dereference then 2687 Subp := Etype (Name (Call_Node)); 2688 Parent_Subp := Empty; 2689 2690 -- Case of call to simple entry, where the Name is a selected component 2691 -- whose prefix is the task, and whose selector name is the entry name 2692 2693 elsif Nkind (Name (Call_Node)) = N_Selected_Component then 2694 Subp := Entity (Selector_Name (Name (Call_Node))); 2695 Parent_Subp := Empty; 2696 2697 -- Case of call to member of entry family, where Name is an indexed 2698 -- component, with the prefix being a selected component giving the 2699 -- task and entry family name, and the index being the entry index. 2700 2701 elsif Nkind (Name (Call_Node)) = N_Indexed_Component then 2702 Subp := Entity (Selector_Name (Prefix (Name (Call_Node)))); 2703 Parent_Subp := Empty; 2704 2705 -- Normal case 2706 2707 else 2708 Subp := Entity (Name (Call_Node)); 2709 Parent_Subp := Alias (Subp); 2710 2711 -- Replace call to Raise_Exception by call to Raise_Exception_Always 2712 -- if we can tell that the first parameter cannot possibly be null. 2713 -- This improves efficiency by avoiding a run-time test. 2714 2715 -- We do not do this if Raise_Exception_Always does not exist, which 2716 -- can happen in configurable run time profiles which provide only a 2717 -- Raise_Exception. 2718 2719 if Is_RTE (Subp, RE_Raise_Exception) 2720 and then RTE_Available (RE_Raise_Exception_Always) 2721 then 2722 declare 2723 FA : constant Node_Id := 2724 Original_Node (First_Actual (Call_Node)); 2725 2726 begin 2727 -- The case we catch is where the first argument is obtained 2728 -- using the Identity attribute (which must always be 2729 -- non-null). 2730 2731 if Nkind (FA) = N_Attribute_Reference 2732 and then Attribute_Name (FA) = Name_Identity 2733 then 2734 Subp := RTE (RE_Raise_Exception_Always); 2735 Set_Name (Call_Node, New_Occurrence_Of (Subp, Loc)); 2736 end if; 2737 end; 2738 end if; 2739 2740 if Ekind (Subp) = E_Entry then 2741 Parent_Subp := Empty; 2742 end if; 2743 end if; 2744 2745 -- Ada 2005 (AI-345): We have a procedure call as a triggering 2746 -- alternative in an asynchronous select or as an entry call in 2747 -- a conditional or timed select. Check whether the procedure call 2748 -- is a renaming of an entry and rewrite it as an entry call. 2749 2750 if Ada_Version >= Ada_2005 2751 and then Nkind (Call_Node) = N_Procedure_Call_Statement 2752 and then 2753 ((Nkind (Parent (Call_Node)) = N_Triggering_Alternative 2754 and then Triggering_Statement (Parent (Call_Node)) = Call_Node) 2755 or else 2756 (Nkind (Parent (Call_Node)) = N_Entry_Call_Alternative 2757 and then Entry_Call_Statement (Parent (Call_Node)) = Call_Node)) 2758 then 2759 declare 2760 Ren_Decl : Node_Id; 2761 Ren_Root : Entity_Id := Subp; 2762 2763 begin 2764 -- This may be a chain of renamings, find the root 2765 2766 if Present (Alias (Ren_Root)) then 2767 Ren_Root := Alias (Ren_Root); 2768 end if; 2769 2770 if Present (Original_Node (Parent (Parent (Ren_Root)))) then 2771 Ren_Decl := Original_Node (Parent (Parent (Ren_Root))); 2772 2773 if Nkind (Ren_Decl) = N_Subprogram_Renaming_Declaration then 2774 Rewrite (Call_Node, 2775 Make_Entry_Call_Statement (Loc, 2776 Name => 2777 New_Copy_Tree (Name (Ren_Decl)), 2778 Parameter_Associations => 2779 New_Copy_List_Tree 2780 (Parameter_Associations (Call_Node)))); 2781 2782 return; 2783 end if; 2784 end if; 2785 end; 2786 end if; 2787 2788 if Modify_Tree_For_C 2789 and then Nkind (Call_Node) = N_Function_Call 2790 and then Is_Entity_Name (Name (Call_Node)) 2791 then 2792 declare 2793 Func_Id : constant Entity_Id := 2794 Ultimate_Alias (Entity (Name (Call_Node))); 2795 begin 2796 -- When generating C code, transform a function call that returns 2797 -- a constrained array type into procedure form. 2798 2799 if Rewritten_For_C (Func_Id) then 2800 2801 -- For internally generated calls ensure that they reference 2802 -- the entity of the spec of the called function (needed since 2803 -- the expander may generate calls using the entity of their 2804 -- body). See for example Expand_Boolean_Operator(). 2805 2806 if not (Comes_From_Source (Call_Node)) 2807 and then Nkind (Unit_Declaration_Node (Func_Id)) = 2808 N_Subprogram_Body 2809 then 2810 Set_Entity (Name (Call_Node), 2811 Corresponding_Function 2812 (Corresponding_Procedure (Func_Id))); 2813 end if; 2814 2815 Rewrite_Function_Call_For_C (Call_Node); 2816 return; 2817 2818 -- Also introduce a temporary for functions that return a record 2819 -- called within another procedure or function call, since records 2820 -- are passed by pointer in the generated C code, and we cannot 2821 -- take a pointer from a subprogram call. 2822 2823 elsif Nkind (Parent (Call_Node)) in N_Subprogram_Call 2824 and then Is_Record_Type (Etype (Func_Id)) 2825 then 2826 declare 2827 Temp_Id : constant Entity_Id := Make_Temporary (Loc, 'T'); 2828 Decl : Node_Id; 2829 2830 begin 2831 -- Generate: 2832 -- Temp : ... := Func_Call (...); 2833 2834 Decl := 2835 Make_Object_Declaration (Loc, 2836 Defining_Identifier => Temp_Id, 2837 Object_Definition => 2838 New_Occurrence_Of (Etype (Func_Id), Loc), 2839 Expression => 2840 Make_Function_Call (Loc, 2841 Name => 2842 New_Occurrence_Of (Func_Id, Loc), 2843 Parameter_Associations => 2844 Parameter_Associations (Call_Node))); 2845 2846 Insert_Action (Parent (Call_Node), Decl); 2847 Rewrite (Call_Node, New_Occurrence_Of (Temp_Id, Loc)); 2848 return; 2849 end; 2850 end if; 2851 end; 2852 end if; 2853 2854 -- First step, compute extra actuals, corresponding to any Extra_Formals 2855 -- present. Note that we do not access Extra_Formals directly, instead 2856 -- we simply note the presence of the extra formals as we process the 2857 -- regular formals collecting corresponding actuals in Extra_Actuals. 2858 2859 -- We also generate any required range checks for actuals for in formals 2860 -- as we go through the loop, since this is a convenient place to do it. 2861 -- (Though it seems that this would be better done in Expand_Actuals???) 2862 2863 -- Special case: Thunks must not compute the extra actuals; they must 2864 -- just propagate to the target primitive their extra actuals. 2865 2866 if Is_Thunk (Current_Scope) 2867 and then Thunk_Entity (Current_Scope) = Subp 2868 and then Present (Extra_Formals (Subp)) 2869 then 2870 pragma Assert (Present (Extra_Formals (Current_Scope))); 2871 2872 declare 2873 Target_Formal : Entity_Id; 2874 Thunk_Formal : Entity_Id; 2875 2876 begin 2877 Target_Formal := Extra_Formals (Subp); 2878 Thunk_Formal := Extra_Formals (Current_Scope); 2879 while Present (Target_Formal) loop 2880 Add_Extra_Actual 2881 (Expr => New_Occurrence_Of (Thunk_Formal, Loc), 2882 EF => Thunk_Formal); 2883 2884 Target_Formal := Extra_Formal (Target_Formal); 2885 Thunk_Formal := Extra_Formal (Thunk_Formal); 2886 end loop; 2887 2888 while Is_Non_Empty_List (Extra_Actuals) loop 2889 Add_Actual_Parameter (Remove_Head (Extra_Actuals)); 2890 end loop; 2891 2892 Expand_Actuals (Call_Node, Subp, Post_Call); 2893 pragma Assert (Is_Empty_List (Post_Call)); 2894 return; 2895 end; 2896 end if; 2897 2898 Formal := First_Formal (Subp); 2899 Actual := First_Actual (Call_Node); 2900 Param_Count := 1; 2901 while Present (Formal) loop 2902 2903 -- Generate range check if required 2904 2905 if Do_Range_Check (Actual) 2906 and then Ekind (Formal) = E_In_Parameter 2907 then 2908 Generate_Range_Check 2909 (Actual, Etype (Formal), CE_Range_Check_Failed); 2910 end if; 2911 2912 -- Prepare to examine current entry 2913 2914 Prev := Actual; 2915 Prev_Orig := Original_Node (Prev); 2916 2917 -- Ada 2005 (AI-251): Check if any formal is a class-wide interface 2918 -- to expand it in a further round. 2919 2920 CW_Interface_Formals_Present := 2921 CW_Interface_Formals_Present 2922 or else 2923 (Is_Class_Wide_Type (Etype (Formal)) 2924 and then Is_Interface (Etype (Etype (Formal)))) 2925 or else 2926 (Ekind (Etype (Formal)) = E_Anonymous_Access_Type 2927 and then Is_Class_Wide_Type (Directly_Designated_Type 2928 (Etype (Etype (Formal)))) 2929 and then Is_Interface (Directly_Designated_Type 2930 (Etype (Etype (Formal))))); 2931 2932 -- Create possible extra actual for constrained case. Usually, the 2933 -- extra actual is of the form actual'constrained, but since this 2934 -- attribute is only available for unconstrained records, TRUE is 2935 -- expanded if the type of the formal happens to be constrained (for 2936 -- instance when this procedure is inherited from an unconstrained 2937 -- record to a constrained one) or if the actual has no discriminant 2938 -- (its type is constrained). An exception to this is the case of a 2939 -- private type without discriminants. In this case we pass FALSE 2940 -- because the object has underlying discriminants with defaults. 2941 2942 if Present (Extra_Constrained (Formal)) then 2943 if Ekind (Etype (Prev)) in Private_Kind 2944 and then not Has_Discriminants (Base_Type (Etype (Prev))) 2945 then 2946 Add_Extra_Actual 2947 (Expr => New_Occurrence_Of (Standard_False, Loc), 2948 EF => Extra_Constrained (Formal)); 2949 2950 elsif Is_Constrained (Etype (Formal)) 2951 or else not Has_Discriminants (Etype (Prev)) 2952 then 2953 Add_Extra_Actual 2954 (Expr => New_Occurrence_Of (Standard_True, Loc), 2955 EF => Extra_Constrained (Formal)); 2956 2957 -- Do not produce extra actuals for Unchecked_Union parameters. 2958 -- Jump directly to the end of the loop. 2959 2960 elsif Is_Unchecked_Union (Base_Type (Etype (Actual))) then 2961 goto Skip_Extra_Actual_Generation; 2962 2963 else 2964 -- If the actual is a type conversion, then the constrained 2965 -- test applies to the actual, not the target type. 2966 2967 declare 2968 Act_Prev : Node_Id; 2969 2970 begin 2971 -- Test for unchecked conversions as well, which can occur 2972 -- as out parameter actuals on calls to stream procedures. 2973 2974 Act_Prev := Prev; 2975 while Nkind_In (Act_Prev, N_Type_Conversion, 2976 N_Unchecked_Type_Conversion) 2977 loop 2978 Act_Prev := Expression (Act_Prev); 2979 end loop; 2980 2981 -- If the expression is a conversion of a dereference, this 2982 -- is internally generated code that manipulates addresses, 2983 -- e.g. when building interface tables. No check should 2984 -- occur in this case, and the discriminated object is not 2985 -- directly a hand. 2986 2987 if not Comes_From_Source (Actual) 2988 and then Nkind (Actual) = N_Unchecked_Type_Conversion 2989 and then Nkind (Act_Prev) = N_Explicit_Dereference 2990 then 2991 Add_Extra_Actual 2992 (Expr => New_Occurrence_Of (Standard_False, Loc), 2993 EF => Extra_Constrained (Formal)); 2994 2995 else 2996 Add_Extra_Actual 2997 (Expr => 2998 Make_Attribute_Reference (Sloc (Prev), 2999 Prefix => 3000 Duplicate_Subexpr_No_Checks 3001 (Act_Prev, Name_Req => True), 3002 Attribute_Name => Name_Constrained), 3003 EF => Extra_Constrained (Formal)); 3004 end if; 3005 end; 3006 end if; 3007 end if; 3008 3009 -- Create possible extra actual for accessibility level 3010 3011 if Present (Extra_Accessibility (Formal)) then 3012 3013 -- Ada 2005 (AI-252): If the actual was rewritten as an Access 3014 -- attribute, then the original actual may be an aliased object 3015 -- occurring as the prefix in a call using "Object.Operation" 3016 -- notation. In that case we must pass the level of the object, 3017 -- so Prev_Orig is reset to Prev and the attribute will be 3018 -- processed by the code for Access attributes further below. 3019 3020 if Prev_Orig /= Prev 3021 and then Nkind (Prev) = N_Attribute_Reference 3022 and then Get_Attribute_Id (Attribute_Name (Prev)) = 3023 Attribute_Access 3024 and then Is_Aliased_View (Prev_Orig) 3025 then 3026 Prev_Orig := Prev; 3027 3028 -- A class-wide precondition generates a test in which formals of 3029 -- the subprogram are replaced by actuals that came from source. 3030 -- In that case as well, the accessiblity comes from the actual. 3031 -- This is the one case in which there are references to formals 3032 -- outside of their subprogram. 3033 3034 elsif Prev_Orig /= Prev 3035 and then Is_Entity_Name (Prev_Orig) 3036 and then Present (Entity (Prev_Orig)) 3037 and then Is_Formal (Entity (Prev_Orig)) 3038 and then not In_Open_Scopes (Scope (Entity (Prev_Orig))) 3039 then 3040 Prev_Orig := Prev; 3041 3042 -- If the actual is a formal of an enclosing subprogram it is 3043 -- the right entity, even if it is a rewriting. This happens 3044 -- when the call is within an inherited condition or predicate. 3045 3046 elsif Is_Entity_Name (Actual) 3047 and then Is_Formal (Entity (Actual)) 3048 and then In_Open_Scopes (Scope (Entity (Actual))) 3049 then 3050 Prev_Orig := Prev; 3051 3052 elsif Nkind (Prev_Orig) = N_Type_Conversion then 3053 Prev_Orig := Expression (Prev_Orig); 3054 end if; 3055 3056 -- Ada 2005 (AI-251): Thunks must propagate the extra actuals of 3057 -- accessibility levels. 3058 3059 if Is_Thunk (Current_Scope) then 3060 declare 3061 Parm_Ent : Entity_Id; 3062 3063 begin 3064 if Is_Controlling_Actual (Actual) then 3065 3066 -- Find the corresponding actual of the thunk 3067 3068 Parm_Ent := First_Entity (Current_Scope); 3069 for J in 2 .. Param_Count loop 3070 Next_Entity (Parm_Ent); 3071 end loop; 3072 3073 -- Handle unchecked conversion of access types generated 3074 -- in thunks (cf. Expand_Interface_Thunk). 3075 3076 elsif Is_Access_Type (Etype (Actual)) 3077 and then Nkind (Actual) = N_Unchecked_Type_Conversion 3078 then 3079 Parm_Ent := Entity (Expression (Actual)); 3080 3081 else pragma Assert (Is_Entity_Name (Actual)); 3082 Parm_Ent := Entity (Actual); 3083 end if; 3084 3085 Add_Extra_Actual 3086 (Expr => 3087 New_Occurrence_Of (Extra_Accessibility (Parm_Ent), Loc), 3088 EF => Extra_Accessibility (Formal)); 3089 end; 3090 3091 elsif Is_Entity_Name (Prev_Orig) then 3092 3093 -- When passing an access parameter, or a renaming of an access 3094 -- parameter, as the actual to another access parameter we need 3095 -- to pass along the actual's own access level parameter. This 3096 -- is done if we are within the scope of the formal access 3097 -- parameter (if this is an inlined body the extra formal is 3098 -- irrelevant). 3099 3100 if (Is_Formal (Entity (Prev_Orig)) 3101 or else 3102 (Present (Renamed_Object (Entity (Prev_Orig))) 3103 and then 3104 Is_Entity_Name (Renamed_Object (Entity (Prev_Orig))) 3105 and then 3106 Is_Formal 3107 (Entity (Renamed_Object (Entity (Prev_Orig)))))) 3108 and then Ekind (Etype (Prev_Orig)) = E_Anonymous_Access_Type 3109 and then In_Open_Scopes (Scope (Entity (Prev_Orig))) 3110 then 3111 declare 3112 Parm_Ent : constant Entity_Id := Param_Entity (Prev_Orig); 3113 3114 begin 3115 pragma Assert (Present (Parm_Ent)); 3116 3117 if Present (Extra_Accessibility (Parm_Ent)) then 3118 Add_Extra_Actual 3119 (Expr => 3120 New_Occurrence_Of 3121 (Extra_Accessibility (Parm_Ent), Loc), 3122 EF => Extra_Accessibility (Formal)); 3123 3124 -- If the actual access parameter does not have an 3125 -- associated extra formal providing its scope level, 3126 -- then treat the actual as having library-level 3127 -- accessibility. 3128 3129 else 3130 Add_Extra_Actual 3131 (Expr => 3132 Make_Integer_Literal (Loc, 3133 Intval => Scope_Depth (Standard_Standard)), 3134 EF => Extra_Accessibility (Formal)); 3135 end if; 3136 end; 3137 3138 -- The actual is a normal access value, so just pass the level 3139 -- of the actual's access type. 3140 3141 else 3142 Add_Extra_Actual 3143 (Expr => Dynamic_Accessibility_Level (Prev_Orig), 3144 EF => Extra_Accessibility (Formal)); 3145 end if; 3146 3147 -- If the actual is an access discriminant, then pass the level 3148 -- of the enclosing object (RM05-3.10.2(12.4/2)). 3149 3150 elsif Nkind (Prev_Orig) = N_Selected_Component 3151 and then Ekind (Entity (Selector_Name (Prev_Orig))) = 3152 E_Discriminant 3153 and then Ekind (Etype (Entity (Selector_Name (Prev_Orig)))) = 3154 E_Anonymous_Access_Type 3155 then 3156 Add_Extra_Actual 3157 (Expr => 3158 Make_Integer_Literal (Loc, 3159 Intval => Object_Access_Level (Prefix (Prev_Orig))), 3160 EF => Extra_Accessibility (Formal)); 3161 3162 -- All other cases 3163 3164 else 3165 case Nkind (Prev_Orig) is 3166 when N_Attribute_Reference => 3167 case Get_Attribute_Id (Attribute_Name (Prev_Orig)) is 3168 3169 -- For X'Access, pass on the level of the prefix X 3170 3171 when Attribute_Access => 3172 3173 -- Accessibility level of S'Access is that of A 3174 3175 Prev_Orig := Prefix (Prev_Orig); 3176 3177 -- If the expression is a view conversion, the 3178 -- accessibility level is that of the expression. 3179 3180 if Nkind (Original_Node (Prev_Orig)) = 3181 N_Type_Conversion 3182 and then 3183 Nkind (Expression (Original_Node (Prev_Orig))) = 3184 N_Explicit_Dereference 3185 then 3186 Prev_Orig := 3187 Expression (Original_Node (Prev_Orig)); 3188 end if; 3189 3190 -- If this is an Access attribute applied to the 3191 -- the current instance object passed to a type 3192 -- initialization procedure, then use the level 3193 -- of the type itself. This is not really correct, 3194 -- as there should be an extra level parameter 3195 -- passed in with _init formals (only in the case 3196 -- where the type is immutably limited), but we 3197 -- don't have an easy way currently to create such 3198 -- an extra formal (init procs aren't ever frozen). 3199 -- For now we just use the level of the type, 3200 -- which may be too shallow, but that works better 3201 -- than passing Object_Access_Level of the type, 3202 -- which can be one level too deep in some cases. 3203 -- ??? 3204 3205 -- A further case that requires special handling 3206 -- is the common idiom E.all'access. If E is a 3207 -- formal of the enclosing subprogram, the 3208 -- accessibility of the expression is that of E. 3209 3210 if Is_Entity_Name (Prev_Orig) then 3211 Pref_Entity := Entity (Prev_Orig); 3212 3213 elsif Nkind (Prev_Orig) = N_Explicit_Dereference 3214 and then Is_Entity_Name (Prefix (Prev_Orig)) 3215 then 3216 Pref_Entity := Entity (Prefix ((Prev_Orig))); 3217 3218 else 3219 Pref_Entity := Empty; 3220 end if; 3221 3222 if Is_Entity_Name (Prev_Orig) 3223 and then Is_Type (Entity (Prev_Orig)) 3224 then 3225 Add_Extra_Actual 3226 (Expr => 3227 Make_Integer_Literal (Loc, 3228 Intval => 3229 Type_Access_Level (Pref_Entity)), 3230 EF => Extra_Accessibility (Formal)); 3231 3232 elsif Nkind (Prev_Orig) = N_Explicit_Dereference 3233 and then Present (Pref_Entity) 3234 and then Is_Formal (Pref_Entity) 3235 and then Present 3236 (Extra_Accessibility (Pref_Entity)) 3237 then 3238 Add_Extra_Actual 3239 (Expr => 3240 New_Occurrence_Of 3241 (Extra_Accessibility (Pref_Entity), Loc), 3242 EF => Extra_Accessibility (Formal)); 3243 3244 else 3245 Add_Extra_Actual 3246 (Expr => 3247 Make_Integer_Literal (Loc, 3248 Intval => 3249 Object_Access_Level (Prev_Orig)), 3250 EF => Extra_Accessibility (Formal)); 3251 end if; 3252 3253 -- Treat the unchecked attributes as library-level 3254 3255 when Attribute_Unchecked_Access 3256 | Attribute_Unrestricted_Access 3257 => 3258 Add_Extra_Actual 3259 (Expr => 3260 Make_Integer_Literal (Loc, 3261 Intval => Scope_Depth (Standard_Standard)), 3262 EF => Extra_Accessibility (Formal)); 3263 3264 -- No other cases of attributes returning access 3265 -- values that can be passed to access parameters. 3266 3267 when others => 3268 raise Program_Error; 3269 3270 end case; 3271 3272 -- For allocators we pass the level of the execution of the 3273 -- called subprogram, which is one greater than the current 3274 -- scope level. 3275 3276 when N_Allocator => 3277 Add_Extra_Actual 3278 (Expr => 3279 Make_Integer_Literal (Loc, 3280 Intval => Scope_Depth (Current_Scope) + 1), 3281 EF => Extra_Accessibility (Formal)); 3282 3283 -- For most other cases we simply pass the level of the 3284 -- actual's access type. The type is retrieved from 3285 -- Prev rather than Prev_Orig, because in some cases 3286 -- Prev_Orig denotes an original expression that has 3287 -- not been analyzed. 3288 3289 when others => 3290 Add_Extra_Actual 3291 (Expr => Dynamic_Accessibility_Level (Prev), 3292 EF => Extra_Accessibility (Formal)); 3293 end case; 3294 end if; 3295 end if; 3296 3297 -- Perform the check of 4.6(49) that prevents a null value from being 3298 -- passed as an actual to an access parameter. Note that the check 3299 -- is elided in the common cases of passing an access attribute or 3300 -- access parameter as an actual. Also, we currently don't enforce 3301 -- this check for expander-generated actuals and when -gnatdj is set. 3302 3303 if Ada_Version >= Ada_2005 then 3304 3305 -- Ada 2005 (AI-231): Check null-excluding access types. Note that 3306 -- the intent of 6.4.1(13) is that null-exclusion checks should 3307 -- not be done for 'out' parameters, even though it refers only 3308 -- to constraint checks, and a null_exclusion is not a constraint. 3309 -- Note that AI05-0196-1 corrects this mistake in the RM. 3310 3311 if Is_Access_Type (Etype (Formal)) 3312 and then Can_Never_Be_Null (Etype (Formal)) 3313 and then Ekind (Formal) /= E_Out_Parameter 3314 and then Nkind (Prev) /= N_Raise_Constraint_Error 3315 and then (Known_Null (Prev) 3316 or else not Can_Never_Be_Null (Etype (Prev))) 3317 then 3318 Install_Null_Excluding_Check (Prev); 3319 end if; 3320 3321 -- Ada_Version < Ada_2005 3322 3323 else 3324 if Ekind (Etype (Formal)) /= E_Anonymous_Access_Type 3325 or else Access_Checks_Suppressed (Subp) 3326 then 3327 null; 3328 3329 elsif Debug_Flag_J then 3330 null; 3331 3332 elsif not Comes_From_Source (Prev) then 3333 null; 3334 3335 elsif Is_Entity_Name (Prev) 3336 and then Ekind (Etype (Prev)) = E_Anonymous_Access_Type 3337 then 3338 null; 3339 3340 elsif Nkind_In (Prev, N_Allocator, N_Attribute_Reference) then 3341 null; 3342 3343 else 3344 Install_Null_Excluding_Check (Prev); 3345 end if; 3346 end if; 3347 3348 -- Perform appropriate validity checks on parameters that 3349 -- are entities. 3350 3351 if Validity_Checks_On then 3352 if (Ekind (Formal) = E_In_Parameter 3353 and then Validity_Check_In_Params) 3354 or else 3355 (Ekind (Formal) = E_In_Out_Parameter 3356 and then Validity_Check_In_Out_Params) 3357 then 3358 -- If the actual is an indexed component of a packed type (or 3359 -- is an indexed or selected component whose prefix recursively 3360 -- meets this condition), it has not been expanded yet. It will 3361 -- be copied in the validity code that follows, and has to be 3362 -- expanded appropriately, so reanalyze it. 3363 3364 -- What we do is just to unset analyzed bits on prefixes till 3365 -- we reach something that does not have a prefix. 3366 3367 declare 3368 Nod : Node_Id; 3369 3370 begin 3371 Nod := Actual; 3372 while Nkind_In (Nod, N_Indexed_Component, 3373 N_Selected_Component) 3374 loop 3375 Set_Analyzed (Nod, False); 3376 Nod := Prefix (Nod); 3377 end loop; 3378 end; 3379 3380 Ensure_Valid (Actual); 3381 end if; 3382 end if; 3383 3384 -- For IN OUT and OUT parameters, ensure that subscripts are valid 3385 -- since this is a left side reference. We only do this for calls 3386 -- from the source program since we assume that compiler generated 3387 -- calls explicitly generate any required checks. We also need it 3388 -- only if we are doing standard validity checks, since clearly it is 3389 -- not needed if validity checks are off, and in subscript validity 3390 -- checking mode, all indexed components are checked with a call 3391 -- directly from Expand_N_Indexed_Component. 3392 3393 if Comes_From_Source (Call_Node) 3394 and then Ekind (Formal) /= E_In_Parameter 3395 and then Validity_Checks_On 3396 and then Validity_Check_Default 3397 and then not Validity_Check_Subscripts 3398 then 3399 Check_Valid_Lvalue_Subscripts (Actual); 3400 end if; 3401 3402 -- Mark any scalar OUT parameter that is a simple variable as no 3403 -- longer known to be valid (unless the type is always valid). This 3404 -- reflects the fact that if an OUT parameter is never set in a 3405 -- procedure, then it can become invalid on the procedure return. 3406 3407 if Ekind (Formal) = E_Out_Parameter 3408 and then Is_Entity_Name (Actual) 3409 and then Ekind (Entity (Actual)) = E_Variable 3410 and then not Is_Known_Valid (Etype (Actual)) 3411 then 3412 Set_Is_Known_Valid (Entity (Actual), False); 3413 end if; 3414 3415 -- For an OUT or IN OUT parameter, if the actual is an entity, then 3416 -- clear current values, since they can be clobbered. We are probably 3417 -- doing this in more places than we need to, but better safe than 3418 -- sorry when it comes to retaining bad current values. 3419 3420 if Ekind (Formal) /= E_In_Parameter 3421 and then Is_Entity_Name (Actual) 3422 and then Present (Entity (Actual)) 3423 then 3424 declare 3425 Ent : constant Entity_Id := Entity (Actual); 3426 Sav : Node_Id; 3427 3428 begin 3429 -- For an OUT or IN OUT parameter that is an assignable entity, 3430 -- we do not want to clobber the Last_Assignment field, since 3431 -- if it is set, it was precisely because it is indeed an OUT 3432 -- or IN OUT parameter. We do reset the Is_Known_Valid flag 3433 -- since the subprogram could have returned in invalid value. 3434 3435 if Ekind_In (Formal, E_Out_Parameter, E_In_Out_Parameter) 3436 and then Is_Assignable (Ent) 3437 then 3438 Sav := Last_Assignment (Ent); 3439 Kill_Current_Values (Ent); 3440 Set_Last_Assignment (Ent, Sav); 3441 Set_Is_Known_Valid (Ent, False); 3442 Set_Is_True_Constant (Ent, False); 3443 3444 -- For all other cases, just kill the current values 3445 3446 else 3447 Kill_Current_Values (Ent); 3448 end if; 3449 end; 3450 end if; 3451 3452 -- If the formal is class wide and the actual is an aggregate, force 3453 -- evaluation so that the back end who does not know about class-wide 3454 -- type, does not generate a temporary of the wrong size. 3455 3456 if not Is_Class_Wide_Type (Etype (Formal)) then 3457 null; 3458 3459 elsif Nkind (Actual) = N_Aggregate 3460 or else (Nkind (Actual) = N_Qualified_Expression 3461 and then Nkind (Expression (Actual)) = N_Aggregate) 3462 then 3463 Force_Evaluation (Actual); 3464 end if; 3465 3466 -- In a remote call, if the formal is of a class-wide type, check 3467 -- that the actual meets the requirements described in E.4(18). 3468 3469 if Remote and then Is_Class_Wide_Type (Etype (Formal)) then 3470 Insert_Action (Actual, 3471 Make_Transportable_Check (Loc, 3472 Duplicate_Subexpr_Move_Checks (Actual))); 3473 end if; 3474 3475 -- Perform invariant checks for all intermediate types in a view 3476 -- conversion after successful return from a call that passes the 3477 -- view conversion as an IN OUT or OUT parameter (RM 7.3.2 (12/3, 3478 -- 13/3, 14/3)). Consider only source conversion in order to avoid 3479 -- generating spurious checks on complex expansion such as object 3480 -- initialization through an extension aggregate. 3481 3482 if Comes_From_Source (N) 3483 and then Ekind (Formal) /= E_In_Parameter 3484 and then Nkind (Actual) = N_Type_Conversion 3485 then 3486 Add_View_Conversion_Invariants (Formal, Actual); 3487 end if; 3488 3489 -- Generating C the initialization of an allocator is performed by 3490 -- means of individual statements, and hence it must be done before 3491 -- the call. 3492 3493 if Modify_Tree_For_C 3494 and then Nkind (Actual) = N_Allocator 3495 and then Nkind (Expression (Actual)) = N_Qualified_Expression 3496 then 3497 Remove_Side_Effects (Actual); 3498 end if; 3499 3500 -- This label is required when skipping extra actual generation for 3501 -- Unchecked_Union parameters. 3502 3503 <<Skip_Extra_Actual_Generation>> 3504 3505 Param_Count := Param_Count + 1; 3506 Next_Actual (Actual); 3507 Next_Formal (Formal); 3508 end loop; 3509 3510 -- If we are calling an Ada 2012 function which needs to have the 3511 -- "accessibility level determined by the point of call" (AI05-0234) 3512 -- passed in to it, then pass it in. 3513 3514 if Ekind_In (Subp, E_Function, E_Operator, E_Subprogram_Type) 3515 and then 3516 Present (Extra_Accessibility_Of_Result (Ultimate_Alias (Subp))) 3517 then 3518 declare 3519 Ancestor : Node_Id := Parent (Call_Node); 3520 Level : Node_Id := Empty; 3521 Defer : Boolean := False; 3522 3523 begin 3524 -- Unimplemented: if Subp returns an anonymous access type, then 3525 3526 -- a) if the call is the operand of an explict conversion, then 3527 -- the target type of the conversion (a named access type) 3528 -- determines the accessibility level pass in; 3529 3530 -- b) if the call defines an access discriminant of an object 3531 -- (e.g., the discriminant of an object being created by an 3532 -- allocator, or the discriminant of a function result), 3533 -- then the accessibility level to pass in is that of the 3534 -- discriminated object being initialized). 3535 3536 -- ??? 3537 3538 while Nkind (Ancestor) = N_Qualified_Expression 3539 loop 3540 Ancestor := Parent (Ancestor); 3541 end loop; 3542 3543 case Nkind (Ancestor) is 3544 when N_Allocator => 3545 3546 -- At this point, we'd like to assign 3547 3548 -- Level := Dynamic_Accessibility_Level (Ancestor); 3549 3550 -- but Etype of Ancestor may not have been set yet, 3551 -- so that doesn't work. 3552 3553 -- Handle this later in Expand_Allocator_Expression. 3554 3555 Defer := True; 3556 3557 when N_Object_Declaration 3558 | N_Object_Renaming_Declaration 3559 => 3560 declare 3561 Def_Id : constant Entity_Id := 3562 Defining_Identifier (Ancestor); 3563 3564 begin 3565 if Is_Return_Object (Def_Id) then 3566 if Present (Extra_Accessibility_Of_Result 3567 (Return_Applies_To (Scope (Def_Id)))) 3568 then 3569 -- Pass along value that was passed in if the 3570 -- routine we are returning from also has an 3571 -- Accessibility_Of_Result formal. 3572 3573 Level := 3574 New_Occurrence_Of 3575 (Extra_Accessibility_Of_Result 3576 (Return_Applies_To (Scope (Def_Id))), Loc); 3577 end if; 3578 else 3579 Level := 3580 Make_Integer_Literal (Loc, 3581 Intval => Object_Access_Level (Def_Id)); 3582 end if; 3583 end; 3584 3585 when N_Simple_Return_Statement => 3586 if Present (Extra_Accessibility_Of_Result 3587 (Return_Applies_To 3588 (Return_Statement_Entity (Ancestor)))) 3589 then 3590 -- Pass along value that was passed in if the returned 3591 -- routine also has an Accessibility_Of_Result formal. 3592 3593 Level := 3594 New_Occurrence_Of 3595 (Extra_Accessibility_Of_Result 3596 (Return_Applies_To 3597 (Return_Statement_Entity (Ancestor))), Loc); 3598 end if; 3599 3600 when others => 3601 null; 3602 end case; 3603 3604 if not Defer then 3605 if not Present (Level) then 3606 3607 -- The "innermost master that evaluates the function call". 3608 3609 -- ??? - Should we use Integer'Last here instead in order 3610 -- to deal with (some of) the problems associated with 3611 -- calls to subps whose enclosing scope is unknown (e.g., 3612 -- Anon_Access_To_Subp_Param.all)? 3613 3614 Level := 3615 Make_Integer_Literal (Loc, 3616 Intval => Scope_Depth (Current_Scope) + 1); 3617 end if; 3618 3619 Add_Extra_Actual 3620 (Expr => Level, 3621 EF => 3622 Extra_Accessibility_Of_Result (Ultimate_Alias (Subp))); 3623 end if; 3624 end; 3625 end if; 3626 3627 -- If we are expanding the RHS of an assignment we need to check if tag 3628 -- propagation is needed. You might expect this processing to be in 3629 -- Analyze_Assignment but has to be done earlier (bottom-up) because the 3630 -- assignment might be transformed to a declaration for an unconstrained 3631 -- value if the expression is classwide. 3632 3633 if Nkind (Call_Node) = N_Function_Call 3634 and then Is_Tag_Indeterminate (Call_Node) 3635 and then Is_Entity_Name (Name (Call_Node)) 3636 then 3637 declare 3638 Ass : Node_Id := Empty; 3639 3640 begin 3641 if Nkind (Parent (Call_Node)) = N_Assignment_Statement then 3642 Ass := Parent (Call_Node); 3643 3644 elsif Nkind (Parent (Call_Node)) = N_Qualified_Expression 3645 and then Nkind (Parent (Parent (Call_Node))) = 3646 N_Assignment_Statement 3647 then 3648 Ass := Parent (Parent (Call_Node)); 3649 3650 elsif Nkind (Parent (Call_Node)) = N_Explicit_Dereference 3651 and then Nkind (Parent (Parent (Call_Node))) = 3652 N_Assignment_Statement 3653 then 3654 Ass := Parent (Parent (Call_Node)); 3655 end if; 3656 3657 if Present (Ass) 3658 and then Is_Class_Wide_Type (Etype (Name (Ass))) 3659 then 3660 if Is_Access_Type (Etype (Call_Node)) then 3661 if Designated_Type (Etype (Call_Node)) /= 3662 Root_Type (Etype (Name (Ass))) 3663 then 3664 Error_Msg_NE 3665 ("tag-indeterminate expression must have designated " 3666 & "type& (RM 5.2 (6))", 3667 Call_Node, Root_Type (Etype (Name (Ass)))); 3668 else 3669 Propagate_Tag (Name (Ass), Call_Node); 3670 end if; 3671 3672 elsif Etype (Call_Node) /= Root_Type (Etype (Name (Ass))) then 3673 Error_Msg_NE 3674 ("tag-indeterminate expression must have type & " 3675 & "(RM 5.2 (6))", 3676 Call_Node, Root_Type (Etype (Name (Ass)))); 3677 3678 else 3679 Propagate_Tag (Name (Ass), Call_Node); 3680 end if; 3681 3682 -- The call will be rewritten as a dispatching call, and 3683 -- expanded as such. 3684 3685 return; 3686 end if; 3687 end; 3688 end if; 3689 3690 -- Ada 2005 (AI-251): If some formal is a class-wide interface, expand 3691 -- it to point to the correct secondary virtual table 3692 3693 if Nkind (Call_Node) in N_Subprogram_Call 3694 and then CW_Interface_Formals_Present 3695 then 3696 Expand_Interface_Actuals (Call_Node); 3697 end if; 3698 3699 -- Deals with Dispatch_Call if we still have a call, before expanding 3700 -- extra actuals since this will be done on the re-analysis of the 3701 -- dispatching call. Note that we do not try to shorten the actual list 3702 -- for a dispatching call, it would not make sense to do so. Expansion 3703 -- of dispatching calls is suppressed for VM targets, because the VM 3704 -- back-ends directly handle the generation of dispatching calls and 3705 -- would have to undo any expansion to an indirect call. 3706 3707 if Nkind (Call_Node) in N_Subprogram_Call 3708 and then Present (Controlling_Argument (Call_Node)) 3709 then 3710 declare 3711 Call_Typ : constant Entity_Id := Etype (Call_Node); 3712 Typ : constant Entity_Id := Find_Dispatching_Type (Subp); 3713 Eq_Prim_Op : Entity_Id := Empty; 3714 New_Call : Node_Id; 3715 Param : Node_Id; 3716 Prev_Call : Node_Id; 3717 3718 begin 3719 if not Is_Limited_Type (Typ) then 3720 Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq); 3721 end if; 3722 3723 if Tagged_Type_Expansion then 3724 Expand_Dispatching_Call (Call_Node); 3725 3726 -- The following return is worrisome. Is it really OK to skip 3727 -- all remaining processing in this procedure ??? 3728 3729 return; 3730 3731 -- VM targets 3732 3733 else 3734 Apply_Tag_Checks (Call_Node); 3735 3736 -- If this is a dispatching "=", we must first compare the 3737 -- tags so we generate: x.tag = y.tag and then x = y 3738 3739 if Subp = Eq_Prim_Op then 3740 3741 -- Mark the node as analyzed to avoid reanalyzing this 3742 -- dispatching call (which would cause a never-ending loop) 3743 3744 Prev_Call := Relocate_Node (Call_Node); 3745 Set_Analyzed (Prev_Call); 3746 3747 Param := First_Actual (Call_Node); 3748 New_Call := 3749 Make_And_Then (Loc, 3750 Left_Opnd => 3751 Make_Op_Eq (Loc, 3752 Left_Opnd => 3753 Make_Selected_Component (Loc, 3754 Prefix => New_Value (Param), 3755 Selector_Name => 3756 New_Occurrence_Of 3757 (First_Tag_Component (Typ), Loc)), 3758 3759 Right_Opnd => 3760 Make_Selected_Component (Loc, 3761 Prefix => 3762 Unchecked_Convert_To (Typ, 3763 New_Value (Next_Actual (Param))), 3764 Selector_Name => 3765 New_Occurrence_Of 3766 (First_Tag_Component (Typ), Loc))), 3767 Right_Opnd => Prev_Call); 3768 3769 Rewrite (Call_Node, New_Call); 3770 3771 Analyze_And_Resolve 3772 (Call_Node, Call_Typ, Suppress => All_Checks); 3773 end if; 3774 3775 -- Expansion of a dispatching call results in an indirect call, 3776 -- which in turn causes current values to be killed (see 3777 -- Resolve_Call), so on VM targets we do the call here to 3778 -- ensure consistent warnings between VM and non-VM targets. 3779 3780 Kill_Current_Values; 3781 end if; 3782 3783 -- If this is a dispatching "=" then we must update the reference 3784 -- to the call node because we generated: 3785 -- x.tag = y.tag and then x = y 3786 3787 if Subp = Eq_Prim_Op then 3788 Call_Node := Right_Opnd (Call_Node); 3789 end if; 3790 end; 3791 end if; 3792 3793 -- Similarly, expand calls to RCI subprograms on which pragma 3794 -- All_Calls_Remote applies. The rewriting will be reanalyzed 3795 -- later. Do this only when the call comes from source since we 3796 -- do not want such a rewriting to occur in expanded code. 3797 3798 if Is_All_Remote_Call (Call_Node) then 3799 Expand_All_Calls_Remote_Subprogram_Call (Call_Node); 3800 3801 -- Similarly, do not add extra actuals for an entry call whose entity 3802 -- is a protected procedure, or for an internal protected subprogram 3803 -- call, because it will be rewritten as a protected subprogram call 3804 -- and reanalyzed (see Expand_Protected_Subprogram_Call). 3805 3806 elsif Is_Protected_Type (Scope (Subp)) 3807 and then (Ekind (Subp) = E_Procedure 3808 or else Ekind (Subp) = E_Function) 3809 then 3810 null; 3811 3812 -- During that loop we gathered the extra actuals (the ones that 3813 -- correspond to Extra_Formals), so now they can be appended. 3814 3815 else 3816 while Is_Non_Empty_List (Extra_Actuals) loop 3817 Add_Actual_Parameter (Remove_Head (Extra_Actuals)); 3818 end loop; 3819 end if; 3820 3821 -- At this point we have all the actuals, so this is the point at which 3822 -- the various expansion activities for actuals is carried out. 3823 3824 Expand_Actuals (Call_Node, Subp, Post_Call); 3825 3826 -- Verify that the actuals do not share storage. This check must be done 3827 -- on the caller side rather that inside the subprogram to avoid issues 3828 -- of parameter passing. 3829 3830 if Check_Aliasing_Of_Parameters then 3831 Apply_Parameter_Aliasing_Checks (Call_Node, Subp); 3832 end if; 3833 3834 -- If the subprogram is a renaming, or if it is inherited, replace it in 3835 -- the call with the name of the actual subprogram being called. If this 3836 -- is a dispatching call, the run-time decides what to call. The Alias 3837 -- attribute does not apply to entries. 3838 3839 if Nkind (Call_Node) /= N_Entry_Call_Statement 3840 and then No (Controlling_Argument (Call_Node)) 3841 and then Present (Parent_Subp) 3842 and then not Is_Direct_Deep_Call (Subp) 3843 then 3844 if Present (Inherited_From_Formal (Subp)) then 3845 Parent_Subp := Inherited_From_Formal (Subp); 3846 else 3847 Parent_Subp := Ultimate_Alias (Parent_Subp); 3848 end if; 3849 3850 -- The below setting of Entity is suspect, see F109-018 discussion??? 3851 3852 Set_Entity (Name (Call_Node), Parent_Subp); 3853 3854 if Is_Abstract_Subprogram (Parent_Subp) 3855 and then not In_Instance 3856 then 3857 Error_Msg_NE 3858 ("cannot call abstract subprogram &!", 3859 Name (Call_Node), Parent_Subp); 3860 end if; 3861 3862 -- Inspect all formals of derived subprogram Subp. Compare parameter 3863 -- types with the parent subprogram and check whether an actual may 3864 -- need a type conversion to the corresponding formal of the parent 3865 -- subprogram. 3866 3867 -- Not clear whether intrinsic subprograms need such conversions. ??? 3868 3869 if not Is_Intrinsic_Subprogram (Parent_Subp) 3870 or else Is_Generic_Instance (Parent_Subp) 3871 then 3872 declare 3873 procedure Convert (Act : Node_Id; Typ : Entity_Id); 3874 -- Rewrite node Act as a type conversion of Act to Typ. Analyze 3875 -- and resolve the newly generated construct. 3876 3877 ------------- 3878 -- Convert -- 3879 ------------- 3880 3881 procedure Convert (Act : Node_Id; Typ : Entity_Id) is 3882 begin 3883 Rewrite (Act, OK_Convert_To (Typ, Relocate_Node (Act))); 3884 Analyze (Act); 3885 Resolve (Act, Typ); 3886 end Convert; 3887 3888 -- Local variables 3889 3890 Actual_Typ : Entity_Id; 3891 Formal_Typ : Entity_Id; 3892 Parent_Typ : Entity_Id; 3893 3894 begin 3895 Actual := First_Actual (Call_Node); 3896 Formal := First_Formal (Subp); 3897 Parent_Formal := First_Formal (Parent_Subp); 3898 while Present (Formal) loop 3899 Actual_Typ := Etype (Actual); 3900 Formal_Typ := Etype (Formal); 3901 Parent_Typ := Etype (Parent_Formal); 3902 3903 -- For an IN parameter of a scalar type, the parent formal 3904 -- type and derived formal type differ or the parent formal 3905 -- type and actual type do not match statically. 3906 3907 if Is_Scalar_Type (Formal_Typ) 3908 and then Ekind (Formal) = E_In_Parameter 3909 and then Formal_Typ /= Parent_Typ 3910 and then 3911 not Subtypes_Statically_Match (Parent_Typ, Actual_Typ) 3912 and then not Raises_Constraint_Error (Actual) 3913 then 3914 Convert (Actual, Parent_Typ); 3915 Enable_Range_Check (Actual); 3916 3917 -- If the actual has been marked as requiring a range 3918 -- check, then generate it here. 3919 3920 if Do_Range_Check (Actual) then 3921 Generate_Range_Check 3922 (Actual, Etype (Formal), CE_Range_Check_Failed); 3923 end if; 3924 3925 -- For access types, the parent formal type and actual type 3926 -- differ. 3927 3928 elsif Is_Access_Type (Formal_Typ) 3929 and then Base_Type (Parent_Typ) /= Base_Type (Actual_Typ) 3930 then 3931 if Ekind (Formal) /= E_In_Parameter then 3932 Convert (Actual, Parent_Typ); 3933 3934 elsif Ekind (Parent_Typ) = E_Anonymous_Access_Type 3935 and then Designated_Type (Parent_Typ) /= 3936 Designated_Type (Actual_Typ) 3937 and then not Is_Controlling_Formal (Formal) 3938 then 3939 -- This unchecked conversion is not necessary unless 3940 -- inlining is enabled, because in that case the type 3941 -- mismatch may become visible in the body about to be 3942 -- inlined. 3943 3944 Rewrite (Actual, 3945 Unchecked_Convert_To (Parent_Typ, 3946 Relocate_Node (Actual))); 3947 Analyze (Actual); 3948 Resolve (Actual, Parent_Typ); 3949 end if; 3950 3951 -- If there is a change of representation, then generate a 3952 -- warning, and do the change of representation. 3953 3954 elsif not Same_Representation (Formal_Typ, Parent_Typ) then 3955 Error_Msg_N 3956 ("??change of representation required", Actual); 3957 Convert (Actual, Parent_Typ); 3958 3959 -- For array and record types, the parent formal type and 3960 -- derived formal type have different sizes or pragma Pack 3961 -- status. 3962 3963 elsif ((Is_Array_Type (Formal_Typ) 3964 and then Is_Array_Type (Parent_Typ)) 3965 or else 3966 (Is_Record_Type (Formal_Typ) 3967 and then Is_Record_Type (Parent_Typ))) 3968 and then 3969 (Esize (Formal_Typ) /= Esize (Parent_Typ) 3970 or else Has_Pragma_Pack (Formal_Typ) /= 3971 Has_Pragma_Pack (Parent_Typ)) 3972 then 3973 Convert (Actual, Parent_Typ); 3974 end if; 3975 3976 Next_Actual (Actual); 3977 Next_Formal (Formal); 3978 Next_Formal (Parent_Formal); 3979 end loop; 3980 end; 3981 end if; 3982 3983 Orig_Subp := Subp; 3984 Subp := Parent_Subp; 3985 end if; 3986 3987 -- Deal with case where call is an explicit dereference 3988 3989 if Nkind (Name (Call_Node)) = N_Explicit_Dereference then 3990 3991 -- Handle case of access to protected subprogram type 3992 3993 if Is_Access_Protected_Subprogram_Type 3994 (Base_Type (Etype (Prefix (Name (Call_Node))))) 3995 then 3996 -- If this is a call through an access to protected operation, the 3997 -- prefix has the form (object'address, operation'access). Rewrite 3998 -- as a for other protected calls: the object is the 1st parameter 3999 -- of the list of actuals. 4000 4001 declare 4002 Call : Node_Id; 4003 Parm : List_Id; 4004 Nam : Node_Id; 4005 Obj : Node_Id; 4006 Ptr : constant Node_Id := Prefix (Name (Call_Node)); 4007 4008 T : constant Entity_Id := 4009 Equivalent_Type (Base_Type (Etype (Ptr))); 4010 4011 D_T : constant Entity_Id := 4012 Designated_Type (Base_Type (Etype (Ptr))); 4013 4014 begin 4015 Obj := 4016 Make_Selected_Component (Loc, 4017 Prefix => Unchecked_Convert_To (T, Ptr), 4018 Selector_Name => 4019 New_Occurrence_Of (First_Entity (T), Loc)); 4020 4021 Nam := 4022 Make_Selected_Component (Loc, 4023 Prefix => Unchecked_Convert_To (T, Ptr), 4024 Selector_Name => 4025 New_Occurrence_Of (Next_Entity (First_Entity (T)), Loc)); 4026 4027 Nam := 4028 Make_Explicit_Dereference (Loc, 4029 Prefix => Nam); 4030 4031 if Present (Parameter_Associations (Call_Node)) then 4032 Parm := Parameter_Associations (Call_Node); 4033 else 4034 Parm := New_List; 4035 end if; 4036 4037 Prepend (Obj, Parm); 4038 4039 if Etype (D_T) = Standard_Void_Type then 4040 Call := 4041 Make_Procedure_Call_Statement (Loc, 4042 Name => Nam, 4043 Parameter_Associations => Parm); 4044 else 4045 Call := 4046 Make_Function_Call (Loc, 4047 Name => Nam, 4048 Parameter_Associations => Parm); 4049 end if; 4050 4051 Set_First_Named_Actual (Call, First_Named_Actual (Call_Node)); 4052 Set_Etype (Call, Etype (D_T)); 4053 4054 -- We do not re-analyze the call to avoid infinite recursion. 4055 -- We analyze separately the prefix and the object, and set 4056 -- the checks on the prefix that would otherwise be emitted 4057 -- when resolving a call. 4058 4059 Rewrite (Call_Node, Call); 4060 Analyze (Nam); 4061 Apply_Access_Check (Nam); 4062 Analyze (Obj); 4063 return; 4064 end; 4065 end if; 4066 end if; 4067 4068 -- If this is a call to an intrinsic subprogram, then perform the 4069 -- appropriate expansion to the corresponding tree node and we 4070 -- are all done (since after that the call is gone). 4071 4072 -- In the case where the intrinsic is to be processed by the back end, 4073 -- the call to Expand_Intrinsic_Call will do nothing, which is fine, 4074 -- since the idea in this case is to pass the call unchanged. If the 4075 -- intrinsic is an inherited unchecked conversion, and the derived type 4076 -- is the target type of the conversion, we must retain it as the return 4077 -- type of the expression. Otherwise the expansion below, which uses the 4078 -- parent operation, will yield the wrong type. 4079 4080 if Is_Intrinsic_Subprogram (Subp) then 4081 Expand_Intrinsic_Call (Call_Node, Subp); 4082 4083 if Nkind (Call_Node) = N_Unchecked_Type_Conversion 4084 and then Parent_Subp /= Orig_Subp 4085 and then Etype (Parent_Subp) /= Etype (Orig_Subp) 4086 then 4087 Set_Etype (Call_Node, Etype (Orig_Subp)); 4088 end if; 4089 4090 return; 4091 end if; 4092 4093 if Ekind_In (Subp, E_Function, E_Procedure) then 4094 4095 -- We perform a simple optimization on calls for To_Address by 4096 -- replacing them with an unchecked conversion. Not only is this 4097 -- efficient, but it also avoids order of elaboration problems when 4098 -- address clauses are inlined (address expression elaborated at the 4099 -- wrong point). 4100 4101 -- We perform this optimization regardless of whether we are in the 4102 -- main unit or in a unit in the context of the main unit, to ensure 4103 -- that the generated tree is the same in both cases, for CodePeer 4104 -- use. 4105 4106 if Is_RTE (Subp, RE_To_Address) then 4107 Rewrite (Call_Node, 4108 Unchecked_Convert_To 4109 (RTE (RE_Address), Relocate_Node (First_Actual (Call_Node)))); 4110 return; 4111 4112 -- A call to a null procedure is replaced by a null statement, but we 4113 -- are not allowed to ignore possible side effects of the call, so we 4114 -- make sure that actuals are evaluated. 4115 -- We also suppress this optimization for GNATCoverage. 4116 4117 elsif Is_Null_Procedure (Subp) 4118 and then not Opt.Suppress_Control_Flow_Optimizations 4119 then 4120 Actual := First_Actual (Call_Node); 4121 while Present (Actual) loop 4122 Remove_Side_Effects (Actual); 4123 Next_Actual (Actual); 4124 end loop; 4125 4126 Rewrite (Call_Node, Make_Null_Statement (Loc)); 4127 return; 4128 end if; 4129 4130 -- Handle inlining. No action needed if the subprogram is not inlined 4131 4132 if not Is_Inlined (Subp) then 4133 null; 4134 4135 -- Frontend inlining of expression functions (performed also when 4136 -- backend inlining is enabled). 4137 4138 elsif Is_Inlinable_Expression_Function (Subp) then 4139 Rewrite (N, New_Copy (Expression_Of_Expression_Function (Subp))); 4140 Analyze (N); 4141 return; 4142 4143 -- Handle frontend inlining 4144 4145 elsif not Back_End_Inlining then 4146 Inlined_Subprogram : declare 4147 Bod : Node_Id; 4148 Must_Inline : Boolean := False; 4149 Spec : constant Node_Id := Unit_Declaration_Node (Subp); 4150 4151 begin 4152 -- Verify that the body to inline has already been seen, and 4153 -- that if the body is in the current unit the inlining does 4154 -- not occur earlier. This avoids order-of-elaboration problems 4155 -- in the back end. 4156 4157 -- This should be documented in sinfo/einfo ??? 4158 4159 if No (Spec) 4160 or else Nkind (Spec) /= N_Subprogram_Declaration 4161 or else No (Body_To_Inline (Spec)) 4162 then 4163 Must_Inline := False; 4164 4165 -- If this an inherited function that returns a private type, 4166 -- do not inline if the full view is an unconstrained array, 4167 -- because such calls cannot be inlined. 4168 4169 elsif Present (Orig_Subp) 4170 and then Is_Array_Type (Etype (Orig_Subp)) 4171 and then not Is_Constrained (Etype (Orig_Subp)) 4172 then 4173 Must_Inline := False; 4174 4175 elsif In_Unfrozen_Instance (Scope (Subp)) then 4176 Must_Inline := False; 4177 4178 else 4179 Bod := Body_To_Inline (Spec); 4180 4181 if (In_Extended_Main_Code_Unit (Call_Node) 4182 or else In_Extended_Main_Code_Unit (Parent (Call_Node)) 4183 or else Has_Pragma_Inline_Always (Subp)) 4184 and then (not In_Same_Extended_Unit (Sloc (Bod), Loc) 4185 or else 4186 Earlier_In_Extended_Unit (Sloc (Bod), Loc)) 4187 then 4188 Must_Inline := True; 4189 4190 -- If we are compiling a package body that is not the main 4191 -- unit, it must be for inlining/instantiation purposes, 4192 -- in which case we inline the call to insure that the same 4193 -- temporaries are generated when compiling the body by 4194 -- itself. Otherwise link errors can occur. 4195 4196 -- If the function being called is itself in the main unit, 4197 -- we cannot inline, because there is a risk of double 4198 -- elaboration and/or circularity: the inlining can make 4199 -- visible a private entity in the body of the main unit, 4200 -- that gigi will see before its sees its proper definition. 4201 4202 elsif not (In_Extended_Main_Code_Unit (Call_Node)) 4203 and then In_Package_Body 4204 then 4205 Must_Inline := not In_Extended_Main_Source_Unit (Subp); 4206 4207 -- Inline calls to _postconditions when generating C code 4208 4209 elsif Modify_Tree_For_C 4210 and then In_Same_Extended_Unit (Sloc (Bod), Loc) 4211 and then Chars (Name (N)) = Name_uPostconditions 4212 then 4213 Must_Inline := True; 4214 end if; 4215 end if; 4216 4217 if Must_Inline then 4218 Expand_Inlined_Call (Call_Node, Subp, Orig_Subp); 4219 4220 else 4221 -- Let the back end handle it 4222 4223 Add_Inlined_Body (Subp, Call_Node); 4224 4225 if Front_End_Inlining 4226 and then Nkind (Spec) = N_Subprogram_Declaration 4227 and then (In_Extended_Main_Code_Unit (Call_Node)) 4228 and then No (Body_To_Inline (Spec)) 4229 and then not Has_Completion (Subp) 4230 and then In_Same_Extended_Unit (Sloc (Spec), Loc) 4231 then 4232 Cannot_Inline 4233 ("cannot inline& (body not seen yet)?", 4234 Call_Node, Subp); 4235 end if; 4236 end if; 4237 end Inlined_Subprogram; 4238 4239 -- Back end inlining: let the back end handle it 4240 4241 elsif No (Unit_Declaration_Node (Subp)) 4242 or else Nkind (Unit_Declaration_Node (Subp)) /= 4243 N_Subprogram_Declaration 4244 or else No (Body_To_Inline (Unit_Declaration_Node (Subp))) 4245 or else Nkind (Body_To_Inline (Unit_Declaration_Node (Subp))) in 4246 N_Entity 4247 then 4248 Add_Inlined_Body (Subp, Call_Node); 4249 4250 -- If the inlined call appears within an instantiation and some 4251 -- level of optimization is required, ensure that the enclosing 4252 -- instance body is available so that the back-end can actually 4253 -- perform the inlining. 4254 4255 if In_Instance 4256 and then Comes_From_Source (Subp) 4257 and then Optimization_Level > 0 4258 then 4259 declare 4260 Decl : Node_Id; 4261 Inst : Entity_Id; 4262 Inst_Node : Node_Id; 4263 4264 begin 4265 Inst := Scope (Subp); 4266 4267 -- Find enclosing instance 4268 4269 while Present (Inst) and then Inst /= Standard_Standard loop 4270 exit when Is_Generic_Instance (Inst); 4271 Inst := Scope (Inst); 4272 end loop; 4273 4274 if Present (Inst) 4275 and then Is_Generic_Instance (Inst) 4276 and then not Is_Inlined (Inst) 4277 then 4278 Set_Is_Inlined (Inst); 4279 Decl := Unit_Declaration_Node (Inst); 4280 4281 -- Do not add a pending instantiation if the body exits 4282 -- already, or if the instance is a compilation unit, or 4283 -- the instance node is missing. 4284 4285 if Present (Corresponding_Body (Decl)) 4286 or else Nkind (Parent (Decl)) = N_Compilation_Unit 4287 or else No (Next (Decl)) 4288 then 4289 null; 4290 4291 else 4292 -- The instantiation node usually follows the package 4293 -- declaration for the instance. If the generic unit 4294 -- has aspect specifications, they are transformed 4295 -- into pragmas in the instance, and the instance node 4296 -- appears after them. 4297 4298 Inst_Node := Next (Decl); 4299 4300 while Nkind (Inst_Node) /= N_Package_Instantiation loop 4301 Inst_Node := Next (Inst_Node); 4302 end loop; 4303 4304 Add_Pending_Instantiation (Inst_Node, Decl); 4305 end if; 4306 end if; 4307 end; 4308 end if; 4309 4310 -- Front end expansion of simple functions returning unconstrained 4311 -- types (see Check_And_Split_Unconstrained_Function). Note that the 4312 -- case of a simple renaming (Body_To_Inline in N_Entity above, see 4313 -- also Build_Renamed_Body) cannot be expanded here because this may 4314 -- give rise to order-of-elaboration issues for the types of the 4315 -- parameters of the subprogram, if any. 4316 4317 else 4318 Expand_Inlined_Call (Call_Node, Subp, Orig_Subp); 4319 end if; 4320 end if; 4321 4322 -- Check for protected subprogram. This is either an intra-object call, 4323 -- or a protected function call. Protected procedure calls are rewritten 4324 -- as entry calls and handled accordingly. 4325 4326 -- In Ada 2005, this may be an indirect call to an access parameter that 4327 -- is an access_to_subprogram. In that case the anonymous type has a 4328 -- scope that is a protected operation, but the call is a regular one. 4329 -- In either case do not expand call if subprogram is eliminated. 4330 4331 Scop := Scope (Subp); 4332 4333 if Nkind (Call_Node) /= N_Entry_Call_Statement 4334 and then Is_Protected_Type (Scop) 4335 and then Ekind (Subp) /= E_Subprogram_Type 4336 and then not Is_Eliminated (Subp) 4337 then 4338 -- If the call is an internal one, it is rewritten as a call to the 4339 -- corresponding unprotected subprogram. 4340 4341 Expand_Protected_Subprogram_Call (Call_Node, Subp, Scop); 4342 end if; 4343 4344 -- Functions returning controlled objects need special attention. If 4345 -- the return type is limited, then the context is initialization and 4346 -- different processing applies. If the call is to a protected function, 4347 -- the expansion above will call Expand_Call recursively. Otherwise the 4348 -- function call is transformed into a temporary which obtains the 4349 -- result from the secondary stack. 4350 4351 if Needs_Finalization (Etype (Subp)) then 4352 if not Is_Build_In_Place_Function_Call (Call_Node) 4353 and then 4354 (No (First_Formal (Subp)) 4355 or else 4356 not Is_Concurrent_Record_Type (Etype (First_Formal (Subp)))) 4357 then 4358 Expand_Ctrl_Function_Call (Call_Node); 4359 4360 -- Build-in-place function calls which appear in anonymous contexts 4361 -- need a transient scope to ensure the proper finalization of the 4362 -- intermediate result after its use. 4363 4364 elsif Is_Build_In_Place_Function_Call (Call_Node) 4365 and then Nkind_In (Parent (Unqual_Conv (Call_Node)), 4366 N_Attribute_Reference, 4367 N_Function_Call, 4368 N_Indexed_Component, 4369 N_Object_Renaming_Declaration, 4370 N_Procedure_Call_Statement, 4371 N_Selected_Component, 4372 N_Slice) 4373 and then 4374 (Ekind (Current_Scope) /= E_Loop 4375 or else Nkind (Parent (N)) /= N_Function_Call 4376 or else not Is_Build_In_Place_Function_Call (Parent (N))) 4377 then 4378 Establish_Transient_Scope (Call_Node, Manage_Sec_Stack => True); 4379 end if; 4380 end if; 4381 end Expand_Call_Helper; 4382 4383 ------------------------------- 4384 -- Expand_Ctrl_Function_Call -- 4385 ------------------------------- 4386 4387 procedure Expand_Ctrl_Function_Call (N : Node_Id) is 4388 function Is_Element_Reference (N : Node_Id) return Boolean; 4389 -- Determine whether node N denotes a reference to an Ada 2012 container 4390 -- element. 4391 4392 -------------------------- 4393 -- Is_Element_Reference -- 4394 -------------------------- 4395 4396 function Is_Element_Reference (N : Node_Id) return Boolean is 4397 Ref : constant Node_Id := Original_Node (N); 4398 4399 begin 4400 -- Analysis marks an element reference by setting the generalized 4401 -- indexing attribute of an indexed component before the component 4402 -- is rewritten into a function call. 4403 4404 return 4405 Nkind (Ref) = N_Indexed_Component 4406 and then Present (Generalized_Indexing (Ref)); 4407 end Is_Element_Reference; 4408 4409 -- Start of processing for Expand_Ctrl_Function_Call 4410 4411 begin 4412 -- Optimization, if the returned value (which is on the sec-stack) is 4413 -- returned again, no need to copy/readjust/finalize, we can just pass 4414 -- the value thru (see Expand_N_Simple_Return_Statement), and thus no 4415 -- attachment is needed 4416 4417 if Nkind (Parent (N)) = N_Simple_Return_Statement then 4418 return; 4419 end if; 4420 4421 -- Resolution is now finished, make sure we don't start analysis again 4422 -- because of the duplication. 4423 4424 Set_Analyzed (N); 4425 4426 -- A function which returns a controlled object uses the secondary 4427 -- stack. Rewrite the call into a temporary which obtains the result of 4428 -- the function using 'reference. 4429 4430 Remove_Side_Effects (N); 4431 4432 -- The side effect removal of the function call produced a temporary. 4433 -- When the context is a case expression, if expression, or expression 4434 -- with actions, the lifetime of the temporary must be extended to match 4435 -- that of the context. Otherwise the function result will be finalized 4436 -- too early and affect the result of the expression. To prevent this 4437 -- unwanted effect, the temporary should not be considered for clean up 4438 -- actions by the general finalization machinery. 4439 4440 -- Exception to this rule are references to Ada 2012 container elements. 4441 -- Such references must be finalized at the end of each iteration of the 4442 -- related quantified expression, otherwise the container will remain 4443 -- busy. 4444 4445 if Nkind (N) = N_Explicit_Dereference 4446 and then Within_Case_Or_If_Expression (N) 4447 and then not Is_Element_Reference (N) 4448 then 4449 Set_Is_Ignored_Transient (Entity (Prefix (N))); 4450 end if; 4451 end Expand_Ctrl_Function_Call; 4452 4453 ---------------------------------------- 4454 -- Expand_N_Extended_Return_Statement -- 4455 ---------------------------------------- 4456 4457 -- If there is a Handled_Statement_Sequence, we rewrite this: 4458 4459 -- return Result : T := <expression> do 4460 -- <handled_seq_of_stms> 4461 -- end return; 4462 4463 -- to be: 4464 4465 -- declare 4466 -- Result : T := <expression>; 4467 -- begin 4468 -- <handled_seq_of_stms> 4469 -- return Result; 4470 -- end; 4471 4472 -- Otherwise (no Handled_Statement_Sequence), we rewrite this: 4473 4474 -- return Result : T := <expression>; 4475 4476 -- to be: 4477 4478 -- return <expression>; 4479 4480 -- unless it's build-in-place or there's no <expression>, in which case 4481 -- we generate: 4482 4483 -- declare 4484 -- Result : T := <expression>; 4485 -- begin 4486 -- return Result; 4487 -- end; 4488 4489 -- Note that this case could have been written by the user as an extended 4490 -- return statement, or could have been transformed to this from a simple 4491 -- return statement. 4492 4493 -- That is, we need to have a reified return object if there are statements 4494 -- (which might refer to it) or if we're doing build-in-place (so we can 4495 -- set its address to the final resting place or if there is no expression 4496 -- (in which case default initial values might need to be set)). 4497 4498 procedure Expand_N_Extended_Return_Statement (N : Node_Id) is 4499 Loc : constant Source_Ptr := Sloc (N); 4500 4501 function Build_Heap_Or_Pool_Allocator 4502 (Temp_Id : Entity_Id; 4503 Temp_Typ : Entity_Id; 4504 Func_Id : Entity_Id; 4505 Ret_Typ : Entity_Id; 4506 Alloc_Expr : Node_Id) return Node_Id; 4507 -- Create the statements necessary to allocate a return object on the 4508 -- heap or user-defined storage pool. The object may need finalization 4509 -- actions depending on the return type. 4510 -- 4511 -- * Controlled case 4512 -- 4513 -- if BIPfinalizationmaster = null then 4514 -- Temp_Id := <Alloc_Expr>; 4515 -- else 4516 -- declare 4517 -- type Ptr_Typ is access Ret_Typ; 4518 -- for Ptr_Typ'Storage_Pool use 4519 -- Base_Pool (BIPfinalizationmaster.all).all; 4520 -- Local : Ptr_Typ; 4521 -- 4522 -- begin 4523 -- procedure Allocate (...) is 4524 -- begin 4525 -- System.Storage_Pools.Subpools.Allocate_Any (...); 4526 -- end Allocate; 4527 -- 4528 -- Local := <Alloc_Expr>; 4529 -- Temp_Id := Temp_Typ (Local); 4530 -- end; 4531 -- end if; 4532 -- 4533 -- * Non-controlled case 4534 -- 4535 -- Temp_Id := <Alloc_Expr>; 4536 -- 4537 -- Temp_Id is the temporary which is used to reference the internally 4538 -- created object in all allocation forms. Temp_Typ is the type of the 4539 -- temporary. Func_Id is the enclosing function. Ret_Typ is the return 4540 -- type of Func_Id. Alloc_Expr is the actual allocator. 4541 4542 function Move_Activation_Chain (Func_Id : Entity_Id) return Node_Id; 4543 -- Construct a call to System.Tasking.Stages.Move_Activation_Chain 4544 -- with parameters: 4545 -- From current activation chain 4546 -- To activation chain passed in by the caller 4547 -- New_Master master passed in by the caller 4548 -- 4549 -- Func_Id is the entity of the function where the extended return 4550 -- statement appears. 4551 4552 ---------------------------------- 4553 -- Build_Heap_Or_Pool_Allocator -- 4554 ---------------------------------- 4555 4556 function Build_Heap_Or_Pool_Allocator 4557 (Temp_Id : Entity_Id; 4558 Temp_Typ : Entity_Id; 4559 Func_Id : Entity_Id; 4560 Ret_Typ : Entity_Id; 4561 Alloc_Expr : Node_Id) return Node_Id 4562 is 4563 begin 4564 pragma Assert (Is_Build_In_Place_Function (Func_Id)); 4565 4566 -- Processing for objects that require finalization actions 4567 4568 if Needs_Finalization (Ret_Typ) then 4569 declare 4570 Decls : constant List_Id := New_List; 4571 Fin_Mas_Id : constant Entity_Id := 4572 Build_In_Place_Formal 4573 (Func_Id, BIP_Finalization_Master); 4574 Orig_Expr : constant Node_Id := 4575 New_Copy_Tree 4576 (Source => Alloc_Expr, 4577 Scopes_In_EWA_OK => True); 4578 Stmts : constant List_Id := New_List; 4579 Desig_Typ : Entity_Id; 4580 Local_Id : Entity_Id; 4581 Pool_Id : Entity_Id; 4582 Ptr_Typ : Entity_Id; 4583 4584 begin 4585 -- Generate: 4586 -- Pool_Id renames Base_Pool (BIPfinalizationmaster.all).all; 4587 4588 Pool_Id := Make_Temporary (Loc, 'P'); 4589 4590 Append_To (Decls, 4591 Make_Object_Renaming_Declaration (Loc, 4592 Defining_Identifier => Pool_Id, 4593 Subtype_Mark => 4594 New_Occurrence_Of (RTE (RE_Root_Storage_Pool), Loc), 4595 Name => 4596 Make_Explicit_Dereference (Loc, 4597 Prefix => 4598 Make_Function_Call (Loc, 4599 Name => 4600 New_Occurrence_Of (RTE (RE_Base_Pool), Loc), 4601 Parameter_Associations => New_List ( 4602 Make_Explicit_Dereference (Loc, 4603 Prefix => 4604 New_Occurrence_Of (Fin_Mas_Id, Loc))))))); 4605 4606 -- Create an access type which uses the storage pool of the 4607 -- caller's master. This additional type is necessary because 4608 -- the finalization master cannot be associated with the type 4609 -- of the temporary. Otherwise the secondary stack allocation 4610 -- will fail. 4611 4612 Desig_Typ := Ret_Typ; 4613 4614 -- Ensure that the build-in-place machinery uses a fat pointer 4615 -- when allocating an unconstrained array on the heap. In this 4616 -- case the result object type is a constrained array type even 4617 -- though the function type is unconstrained. 4618 4619 if Ekind (Desig_Typ) = E_Array_Subtype then 4620 Desig_Typ := Base_Type (Desig_Typ); 4621 end if; 4622 4623 -- Generate: 4624 -- type Ptr_Typ is access Desig_Typ; 4625 4626 Ptr_Typ := Make_Temporary (Loc, 'P'); 4627 4628 Append_To (Decls, 4629 Make_Full_Type_Declaration (Loc, 4630 Defining_Identifier => Ptr_Typ, 4631 Type_Definition => 4632 Make_Access_To_Object_Definition (Loc, 4633 Subtype_Indication => 4634 New_Occurrence_Of (Desig_Typ, Loc)))); 4635 4636 -- Perform minor decoration in order to set the master and the 4637 -- storage pool attributes. 4638 4639 Set_Ekind (Ptr_Typ, E_Access_Type); 4640 Set_Finalization_Master (Ptr_Typ, Fin_Mas_Id); 4641 Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id); 4642 4643 -- Create the temporary, generate: 4644 -- Local_Id : Ptr_Typ; 4645 4646 Local_Id := Make_Temporary (Loc, 'T'); 4647 4648 Append_To (Decls, 4649 Make_Object_Declaration (Loc, 4650 Defining_Identifier => Local_Id, 4651 Object_Definition => 4652 New_Occurrence_Of (Ptr_Typ, Loc))); 4653 4654 -- Allocate the object, generate: 4655 -- Local_Id := <Alloc_Expr>; 4656 4657 Append_To (Stmts, 4658 Make_Assignment_Statement (Loc, 4659 Name => New_Occurrence_Of (Local_Id, Loc), 4660 Expression => Alloc_Expr)); 4661 4662 -- Generate: 4663 -- Temp_Id := Temp_Typ (Local_Id); 4664 4665 Append_To (Stmts, 4666 Make_Assignment_Statement (Loc, 4667 Name => New_Occurrence_Of (Temp_Id, Loc), 4668 Expression => 4669 Unchecked_Convert_To (Temp_Typ, 4670 New_Occurrence_Of (Local_Id, Loc)))); 4671 4672 -- Wrap the allocation in a block. This is further conditioned 4673 -- by checking the caller finalization master at runtime. A 4674 -- null value indicates a non-existent master, most likely due 4675 -- to a Finalize_Storage_Only allocation. 4676 4677 -- Generate: 4678 -- if BIPfinalizationmaster = null then 4679 -- Temp_Id := <Orig_Expr>; 4680 -- else 4681 -- declare 4682 -- <Decls> 4683 -- begin 4684 -- <Stmts> 4685 -- end; 4686 -- end if; 4687 4688 return 4689 Make_If_Statement (Loc, 4690 Condition => 4691 Make_Op_Eq (Loc, 4692 Left_Opnd => New_Occurrence_Of (Fin_Mas_Id, Loc), 4693 Right_Opnd => Make_Null (Loc)), 4694 4695 Then_Statements => New_List ( 4696 Make_Assignment_Statement (Loc, 4697 Name => New_Occurrence_Of (Temp_Id, Loc), 4698 Expression => Orig_Expr)), 4699 4700 Else_Statements => New_List ( 4701 Make_Block_Statement (Loc, 4702 Declarations => Decls, 4703 Handled_Statement_Sequence => 4704 Make_Handled_Sequence_Of_Statements (Loc, 4705 Statements => Stmts)))); 4706 end; 4707 4708 -- For all other cases, generate: 4709 -- Temp_Id := <Alloc_Expr>; 4710 4711 else 4712 return 4713 Make_Assignment_Statement (Loc, 4714 Name => New_Occurrence_Of (Temp_Id, Loc), 4715 Expression => Alloc_Expr); 4716 end if; 4717 end Build_Heap_Or_Pool_Allocator; 4718 4719 --------------------------- 4720 -- Move_Activation_Chain -- 4721 --------------------------- 4722 4723 function Move_Activation_Chain (Func_Id : Entity_Id) return Node_Id is 4724 begin 4725 return 4726 Make_Procedure_Call_Statement (Loc, 4727 Name => 4728 New_Occurrence_Of (RTE (RE_Move_Activation_Chain), Loc), 4729 4730 Parameter_Associations => New_List ( 4731 4732 -- Source chain 4733 4734 Make_Attribute_Reference (Loc, 4735 Prefix => Make_Identifier (Loc, Name_uChain), 4736 Attribute_Name => Name_Unrestricted_Access), 4737 4738 -- Destination chain 4739 4740 New_Occurrence_Of 4741 (Build_In_Place_Formal (Func_Id, BIP_Activation_Chain), Loc), 4742 4743 -- New master 4744 4745 New_Occurrence_Of 4746 (Build_In_Place_Formal (Func_Id, BIP_Task_Master), Loc))); 4747 end Move_Activation_Chain; 4748 4749 -- Local variables 4750 4751 Func_Id : constant Entity_Id := 4752 Return_Applies_To (Return_Statement_Entity (N)); 4753 Is_BIP_Func : constant Boolean := 4754 Is_Build_In_Place_Function (Func_Id); 4755 Ret_Obj_Id : constant Entity_Id := 4756 First_Entity (Return_Statement_Entity (N)); 4757 Ret_Obj_Decl : constant Node_Id := Parent (Ret_Obj_Id); 4758 Ret_Typ : constant Entity_Id := Etype (Func_Id); 4759 4760 Exp : Node_Id; 4761 HSS : Node_Id; 4762 Result : Node_Id; 4763 Stmts : List_Id; 4764 4765 Return_Stmt : Node_Id := Empty; 4766 -- Force initialization to facilitate static analysis 4767 4768 -- Start of processing for Expand_N_Extended_Return_Statement 4769 4770 begin 4771 -- Given that functionality of interface thunks is simple (just displace 4772 -- the pointer to the object) they are always handled by means of 4773 -- simple return statements. 4774 4775 pragma Assert (not Is_Thunk (Current_Subprogram)); 4776 4777 if Nkind (Ret_Obj_Decl) = N_Object_Declaration then 4778 Exp := Expression (Ret_Obj_Decl); 4779 4780 -- Assert that if F says "return R : T := G(...) do..." 4781 -- then F and G are both b-i-p, or neither b-i-p. 4782 4783 if Nkind (Exp) = N_Function_Call then 4784 pragma Assert (Ekind (Current_Subprogram) = E_Function); 4785 pragma Assert 4786 (Is_Build_In_Place_Function (Current_Subprogram) = 4787 Is_Build_In_Place_Function_Call (Exp)); 4788 null; 4789 end if; 4790 else 4791 Exp := Empty; 4792 end if; 4793 4794 HSS := Handled_Statement_Sequence (N); 4795 4796 -- If the returned object needs finalization actions, the function must 4797 -- perform the appropriate cleanup should it fail to return. The state 4798 -- of the function itself is tracked through a flag which is coupled 4799 -- with the scope finalizer. There is one flag per each return object 4800 -- in case of multiple returns. 4801 4802 if Is_BIP_Func and then Needs_Finalization (Etype (Ret_Obj_Id)) then 4803 declare 4804 Flag_Decl : Node_Id; 4805 Flag_Id : Entity_Id; 4806 Func_Bod : Node_Id; 4807 4808 begin 4809 -- Recover the function body 4810 4811 Func_Bod := Unit_Declaration_Node (Func_Id); 4812 4813 if Nkind (Func_Bod) = N_Subprogram_Declaration then 4814 Func_Bod := Parent (Parent (Corresponding_Body (Func_Bod))); 4815 end if; 4816 4817 if Nkind (Func_Bod) = N_Function_Specification then 4818 Func_Bod := Parent (Func_Bod); -- one more level for child units 4819 end if; 4820 4821 pragma Assert (Nkind (Func_Bod) = N_Subprogram_Body); 4822 4823 -- Create a flag to track the function state 4824 4825 Flag_Id := Make_Temporary (Loc, 'F'); 4826 Set_Status_Flag_Or_Transient_Decl (Ret_Obj_Id, Flag_Id); 4827 4828 -- Insert the flag at the beginning of the function declarations, 4829 -- generate: 4830 -- Fnn : Boolean := False; 4831 4832 Flag_Decl := 4833 Make_Object_Declaration (Loc, 4834 Defining_Identifier => Flag_Id, 4835 Object_Definition => 4836 New_Occurrence_Of (Standard_Boolean, Loc), 4837 Expression => 4838 New_Occurrence_Of (Standard_False, Loc)); 4839 4840 Prepend_To (Declarations (Func_Bod), Flag_Decl); 4841 Analyze (Flag_Decl); 4842 end; 4843 end if; 4844 4845 -- Build a simple_return_statement that returns the return object when 4846 -- there is a statement sequence, or no expression, or the result will 4847 -- be built in place. Note however that we currently do this for all 4848 -- composite cases, even though not all are built in place. 4849 4850 if Present (HSS) 4851 or else Is_Composite_Type (Ret_Typ) 4852 or else No (Exp) 4853 then 4854 if No (HSS) then 4855 Stmts := New_List; 4856 4857 -- If the extended return has a handled statement sequence, then wrap 4858 -- it in a block and use the block as the first statement. 4859 4860 else 4861 Stmts := New_List ( 4862 Make_Block_Statement (Loc, 4863 Declarations => New_List, 4864 Handled_Statement_Sequence => HSS)); 4865 end if; 4866 4867 -- If the result type contains tasks, we call Move_Activation_Chain. 4868 -- Later, the cleanup code will call Complete_Master, which will 4869 -- terminate any unactivated tasks belonging to the return statement 4870 -- master. But Move_Activation_Chain updates their master to be that 4871 -- of the caller, so they will not be terminated unless the return 4872 -- statement completes unsuccessfully due to exception, abort, goto, 4873 -- or exit. As a formality, we test whether the function requires the 4874 -- result to be built in place, though that's necessarily true for 4875 -- the case of result types with task parts. 4876 4877 if Is_BIP_Func and then Has_Task (Ret_Typ) then 4878 4879 -- The return expression is an aggregate for a complex type which 4880 -- contains tasks. This particular case is left unexpanded since 4881 -- the regular expansion would insert all temporaries and 4882 -- initialization code in the wrong block. 4883 4884 if Nkind (Exp) = N_Aggregate then 4885 Expand_N_Aggregate (Exp); 4886 end if; 4887 4888 -- Do not move the activation chain if the return object does not 4889 -- contain tasks. 4890 4891 if Has_Task (Etype (Ret_Obj_Id)) then 4892 Append_To (Stmts, Move_Activation_Chain (Func_Id)); 4893 end if; 4894 end if; 4895 4896 -- Update the state of the function right before the object is 4897 -- returned. 4898 4899 if Is_BIP_Func and then Needs_Finalization (Etype (Ret_Obj_Id)) then 4900 declare 4901 Flag_Id : constant Entity_Id := 4902 Status_Flag_Or_Transient_Decl (Ret_Obj_Id); 4903 4904 begin 4905 -- Generate: 4906 -- Fnn := True; 4907 4908 Append_To (Stmts, 4909 Make_Assignment_Statement (Loc, 4910 Name => New_Occurrence_Of (Flag_Id, Loc), 4911 Expression => New_Occurrence_Of (Standard_True, Loc))); 4912 end; 4913 end if; 4914 4915 -- Build a simple_return_statement that returns the return object 4916 4917 Return_Stmt := 4918 Make_Simple_Return_Statement (Loc, 4919 Expression => New_Occurrence_Of (Ret_Obj_Id, Loc)); 4920 Append_To (Stmts, Return_Stmt); 4921 4922 HSS := Make_Handled_Sequence_Of_Statements (Loc, Stmts); 4923 end if; 4924 4925 -- Case where we build a return statement block 4926 4927 if Present (HSS) then 4928 Result := 4929 Make_Block_Statement (Loc, 4930 Declarations => Return_Object_Declarations (N), 4931 Handled_Statement_Sequence => HSS); 4932 4933 -- We set the entity of the new block statement to be that of the 4934 -- return statement. This is necessary so that various fields, such 4935 -- as Finalization_Chain_Entity carry over from the return statement 4936 -- to the block. Note that this block is unusual, in that its entity 4937 -- is an E_Return_Statement rather than an E_Block. 4938 4939 Set_Identifier 4940 (Result, New_Occurrence_Of (Return_Statement_Entity (N), Loc)); 4941 4942 -- If the object decl was already rewritten as a renaming, then we 4943 -- don't want to do the object allocation and transformation of 4944 -- the return object declaration to a renaming. This case occurs 4945 -- when the return object is initialized by a call to another 4946 -- build-in-place function, and that function is responsible for 4947 -- the allocation of the return object. 4948 4949 if Is_BIP_Func 4950 and then Nkind (Ret_Obj_Decl) = N_Object_Renaming_Declaration 4951 then 4952 pragma Assert 4953 (Nkind (Original_Node (Ret_Obj_Decl)) = N_Object_Declaration 4954 and then 4955 4956 -- It is a regular BIP object declaration 4957 4958 (Is_Build_In_Place_Function_Call 4959 (Expression (Original_Node (Ret_Obj_Decl))) 4960 4961 -- It is a BIP object declaration that displaces the pointer 4962 -- to the object to reference a convered interface type. 4963 4964 or else 4965 Present (Unqual_BIP_Iface_Function_Call 4966 (Expression (Original_Node (Ret_Obj_Decl)))))); 4967 4968 -- Return the build-in-place result by reference 4969 4970 Set_By_Ref (Return_Stmt); 4971 4972 elsif Is_BIP_Func then 4973 4974 -- Locate the implicit access parameter associated with the 4975 -- caller-supplied return object and convert the return 4976 -- statement's return object declaration to a renaming of a 4977 -- dereference of the access parameter. If the return object's 4978 -- declaration includes an expression that has not already been 4979 -- expanded as separate assignments, then add an assignment 4980 -- statement to ensure the return object gets initialized. 4981 4982 -- declare 4983 -- Result : T [:= <expression>]; 4984 -- begin 4985 -- ... 4986 4987 -- is converted to 4988 4989 -- declare 4990 -- Result : T renames FuncRA.all; 4991 -- [Result := <expression;] 4992 -- begin 4993 -- ... 4994 4995 declare 4996 Ret_Obj_Expr : constant Node_Id := Expression (Ret_Obj_Decl); 4997 Ret_Obj_Typ : constant Entity_Id := Etype (Ret_Obj_Id); 4998 4999 Init_Assignment : Node_Id := Empty; 5000 Obj_Acc_Formal : Entity_Id; 5001 Obj_Acc_Deref : Node_Id; 5002 Obj_Alloc_Formal : Entity_Id; 5003 5004 begin 5005 -- Build-in-place results must be returned by reference 5006 5007 Set_By_Ref (Return_Stmt); 5008 5009 -- Retrieve the implicit access parameter passed by the caller 5010 5011 Obj_Acc_Formal := 5012 Build_In_Place_Formal (Func_Id, BIP_Object_Access); 5013 5014 -- If the return object's declaration includes an expression 5015 -- and the declaration isn't marked as No_Initialization, then 5016 -- we need to generate an assignment to the object and insert 5017 -- it after the declaration before rewriting it as a renaming 5018 -- (otherwise we'll lose the initialization). The case where 5019 -- the result type is an interface (or class-wide interface) 5020 -- is also excluded because the context of the function call 5021 -- must be unconstrained, so the initialization will always 5022 -- be done as part of an allocator evaluation (storage pool 5023 -- or secondary stack), never to a constrained target object 5024 -- passed in by the caller. Besides the assignment being 5025 -- unneeded in this case, it avoids problems with trying to 5026 -- generate a dispatching assignment when the return expression 5027 -- is a nonlimited descendant of a limited interface (the 5028 -- interface has no assignment operation). 5029 5030 if Present (Ret_Obj_Expr) 5031 and then not No_Initialization (Ret_Obj_Decl) 5032 and then not Is_Interface (Ret_Obj_Typ) 5033 then 5034 Init_Assignment := 5035 Make_Assignment_Statement (Loc, 5036 Name => New_Occurrence_Of (Ret_Obj_Id, Loc), 5037 Expression => 5038 New_Copy_Tree 5039 (Source => Ret_Obj_Expr, 5040 Scopes_In_EWA_OK => True)); 5041 5042 Set_Etype (Name (Init_Assignment), Etype (Ret_Obj_Id)); 5043 Set_Assignment_OK (Name (Init_Assignment)); 5044 Set_No_Ctrl_Actions (Init_Assignment); 5045 5046 Set_Parent (Name (Init_Assignment), Init_Assignment); 5047 Set_Parent (Expression (Init_Assignment), Init_Assignment); 5048 5049 Set_Expression (Ret_Obj_Decl, Empty); 5050 5051 if Is_Class_Wide_Type (Etype (Ret_Obj_Id)) 5052 and then not Is_Class_Wide_Type 5053 (Etype (Expression (Init_Assignment))) 5054 then 5055 Rewrite (Expression (Init_Assignment), 5056 Make_Type_Conversion (Loc, 5057 Subtype_Mark => 5058 New_Occurrence_Of (Etype (Ret_Obj_Id), Loc), 5059 Expression => 5060 Relocate_Node (Expression (Init_Assignment)))); 5061 end if; 5062 5063 -- In the case of functions where the calling context can 5064 -- determine the form of allocation needed, initialization 5065 -- is done with each part of the if statement that handles 5066 -- the different forms of allocation (this is true for 5067 -- unconstrained, tagged, and controlled result subtypes). 5068 5069 if not Needs_BIP_Alloc_Form (Func_Id) then 5070 Insert_After (Ret_Obj_Decl, Init_Assignment); 5071 end if; 5072 end if; 5073 5074 -- When the function's subtype is unconstrained, a run-time 5075 -- test is needed to determine the form of allocation to use 5076 -- for the return object. The function has an implicit formal 5077 -- parameter indicating this. If the BIP_Alloc_Form formal has 5078 -- the value one, then the caller has passed access to an 5079 -- existing object for use as the return object. If the value 5080 -- is two, then the return object must be allocated on the 5081 -- secondary stack. Otherwise, the object must be allocated in 5082 -- a storage pool. We generate an if statement to test the 5083 -- implicit allocation formal and initialize a local access 5084 -- value appropriately, creating allocators in the secondary 5085 -- stack and global heap cases. The special formal also exists 5086 -- and must be tested when the function has a tagged result, 5087 -- even when the result subtype is constrained, because in 5088 -- general such functions can be called in dispatching contexts 5089 -- and must be handled similarly to functions with a class-wide 5090 -- result. 5091 5092 if Needs_BIP_Alloc_Form (Func_Id) then 5093 Obj_Alloc_Formal := 5094 Build_In_Place_Formal (Func_Id, BIP_Alloc_Form); 5095 5096 declare 5097 Pool_Id : constant Entity_Id := 5098 Make_Temporary (Loc, 'P'); 5099 Alloc_Obj_Id : Entity_Id; 5100 Alloc_Obj_Decl : Node_Id; 5101 Alloc_If_Stmt : Node_Id; 5102 Guard_Except : Node_Id; 5103 Heap_Allocator : Node_Id; 5104 Pool_Decl : Node_Id; 5105 Pool_Allocator : Node_Id; 5106 Ptr_Type_Decl : Node_Id; 5107 Ref_Type : Entity_Id; 5108 SS_Allocator : Node_Id; 5109 5110 begin 5111 -- Reuse the itype created for the function's implicit 5112 -- access formal. This avoids the need to create a new 5113 -- access type here, plus it allows assigning the access 5114 -- formal directly without applying a conversion. 5115 5116 -- Ref_Type := Etype (Object_Access); 5117 5118 -- Create an access type designating the function's 5119 -- result subtype. 5120 5121 Ref_Type := Make_Temporary (Loc, 'A'); 5122 5123 Ptr_Type_Decl := 5124 Make_Full_Type_Declaration (Loc, 5125 Defining_Identifier => Ref_Type, 5126 Type_Definition => 5127 Make_Access_To_Object_Definition (Loc, 5128 All_Present => True, 5129 Subtype_Indication => 5130 New_Occurrence_Of (Ret_Obj_Typ, Loc))); 5131 5132 Insert_Before (Ret_Obj_Decl, Ptr_Type_Decl); 5133 5134 -- Create an access object that will be initialized to an 5135 -- access value denoting the return object, either coming 5136 -- from an implicit access value passed in by the caller 5137 -- or from the result of an allocator. 5138 5139 Alloc_Obj_Id := Make_Temporary (Loc, 'R'); 5140 Set_Etype (Alloc_Obj_Id, Ref_Type); 5141 5142 Alloc_Obj_Decl := 5143 Make_Object_Declaration (Loc, 5144 Defining_Identifier => Alloc_Obj_Id, 5145 Object_Definition => 5146 New_Occurrence_Of (Ref_Type, Loc)); 5147 5148 Insert_Before (Ret_Obj_Decl, Alloc_Obj_Decl); 5149 5150 -- Create allocators for both the secondary stack and 5151 -- global heap. If there's an initialization expression, 5152 -- then create these as initialized allocators. 5153 5154 if Present (Ret_Obj_Expr) 5155 and then not No_Initialization (Ret_Obj_Decl) 5156 then 5157 -- Always use the type of the expression for the 5158 -- qualified expression, rather than the result type. 5159 -- In general we cannot always use the result type 5160 -- for the allocator, because the expression might be 5161 -- of a specific type, such as in the case of an 5162 -- aggregate or even a nonlimited object when the 5163 -- result type is a limited class-wide interface type. 5164 5165 Heap_Allocator := 5166 Make_Allocator (Loc, 5167 Expression => 5168 Make_Qualified_Expression (Loc, 5169 Subtype_Mark => 5170 New_Occurrence_Of 5171 (Etype (Ret_Obj_Expr), Loc), 5172 Expression => 5173 New_Copy_Tree 5174 (Source => Ret_Obj_Expr, 5175 Scopes_In_EWA_OK => True))); 5176 5177 else 5178 -- If the function returns a class-wide type we cannot 5179 -- use the return type for the allocator. Instead we 5180 -- use the type of the expression, which must be an 5181 -- aggregate of a definite type. 5182 5183 if Is_Class_Wide_Type (Ret_Obj_Typ) then 5184 Heap_Allocator := 5185 Make_Allocator (Loc, 5186 Expression => 5187 New_Occurrence_Of 5188 (Etype (Ret_Obj_Expr), Loc)); 5189 else 5190 Heap_Allocator := 5191 Make_Allocator (Loc, 5192 Expression => 5193 New_Occurrence_Of (Ret_Obj_Typ, Loc)); 5194 end if; 5195 5196 -- If the object requires default initialization then 5197 -- that will happen later following the elaboration of 5198 -- the object renaming. If we don't turn it off here 5199 -- then the object will be default initialized twice. 5200 5201 Set_No_Initialization (Heap_Allocator); 5202 end if; 5203 5204 -- Set the flag indicating that the allocator came from 5205 -- a build-in-place return statement, so we can avoid 5206 -- adjusting the allocated object. Note that this flag 5207 -- will be inherited by the copies made below. 5208 5209 Set_Alloc_For_BIP_Return (Heap_Allocator); 5210 5211 -- The Pool_Allocator is just like the Heap_Allocator, 5212 -- except we set Storage_Pool and Procedure_To_Call so 5213 -- it will use the user-defined storage pool. 5214 5215 Pool_Allocator := 5216 New_Copy_Tree 5217 (Source => Heap_Allocator, 5218 Scopes_In_EWA_OK => True); 5219 5220 pragma Assert (Alloc_For_BIP_Return (Pool_Allocator)); 5221 5222 -- Do not generate the renaming of the build-in-place 5223 -- pool parameter on ZFP because the parameter is not 5224 -- created in the first place. 5225 5226 if RTE_Available (RE_Root_Storage_Pool_Ptr) then 5227 Pool_Decl := 5228 Make_Object_Renaming_Declaration (Loc, 5229 Defining_Identifier => Pool_Id, 5230 Subtype_Mark => 5231 New_Occurrence_Of 5232 (RTE (RE_Root_Storage_Pool), Loc), 5233 Name => 5234 Make_Explicit_Dereference (Loc, 5235 New_Occurrence_Of 5236 (Build_In_Place_Formal 5237 (Func_Id, BIP_Storage_Pool), Loc))); 5238 Set_Storage_Pool (Pool_Allocator, Pool_Id); 5239 Set_Procedure_To_Call 5240 (Pool_Allocator, RTE (RE_Allocate_Any)); 5241 else 5242 Pool_Decl := Make_Null_Statement (Loc); 5243 end if; 5244 5245 -- If the No_Allocators restriction is active, then only 5246 -- an allocator for secondary stack allocation is needed. 5247 -- It's OK for such allocators to have Comes_From_Source 5248 -- set to False, because gigi knows not to flag them as 5249 -- being a violation of No_Implicit_Heap_Allocations. 5250 5251 if Restriction_Active (No_Allocators) then 5252 SS_Allocator := Heap_Allocator; 5253 Heap_Allocator := Make_Null (Loc); 5254 Pool_Allocator := Make_Null (Loc); 5255 5256 -- Otherwise the heap and pool allocators may be needed, 5257 -- so we make another allocator for secondary stack 5258 -- allocation. 5259 5260 else 5261 SS_Allocator := 5262 New_Copy_Tree 5263 (Source => Heap_Allocator, 5264 Scopes_In_EWA_OK => True); 5265 5266 pragma Assert (Alloc_For_BIP_Return (SS_Allocator)); 5267 5268 -- The heap and pool allocators are marked as 5269 -- Comes_From_Source since they correspond to an 5270 -- explicit user-written allocator (that is, it will 5271 -- only be executed on behalf of callers that call the 5272 -- function as initialization for such an allocator). 5273 -- Prevents errors when No_Implicit_Heap_Allocations 5274 -- is in force. 5275 5276 Set_Comes_From_Source (Heap_Allocator, True); 5277 Set_Comes_From_Source (Pool_Allocator, True); 5278 end if; 5279 5280 -- The allocator is returned on the secondary stack 5281 5282 Check_Restriction (No_Secondary_Stack, N); 5283 Set_Storage_Pool (SS_Allocator, RTE (RE_SS_Pool)); 5284 Set_Procedure_To_Call 5285 (SS_Allocator, RTE (RE_SS_Allocate)); 5286 5287 -- The allocator is returned on the secondary stack, 5288 -- so indicate that the function return, as well as 5289 -- all blocks that encloses the allocator, must not 5290 -- release it. The flags must be set now because 5291 -- the decision to use the secondary stack is done 5292 -- very late in the course of expanding the return 5293 -- statement, past the point where these flags are 5294 -- normally set. 5295 5296 Set_Uses_Sec_Stack (Func_Id); 5297 Set_Uses_Sec_Stack (Return_Statement_Entity (N)); 5298 Set_Sec_Stack_Needed_For_Return 5299 (Return_Statement_Entity (N)); 5300 Set_Enclosing_Sec_Stack_Return (N); 5301 5302 -- Guard against poor expansion on the caller side by 5303 -- using a raise statement to catch out-of-range values 5304 -- of formal parameter BIP_Alloc_Form. 5305 5306 if Exceptions_OK then 5307 Guard_Except := 5308 Make_Raise_Program_Error (Loc, 5309 Reason => PE_Build_In_Place_Mismatch); 5310 else 5311 Guard_Except := Make_Null_Statement (Loc); 5312 end if; 5313 5314 -- Create an if statement to test the BIP_Alloc_Form 5315 -- formal and initialize the access object to either the 5316 -- BIP_Object_Access formal (BIP_Alloc_Form = 5317 -- Caller_Allocation), the result of allocating the 5318 -- object in the secondary stack (BIP_Alloc_Form = 5319 -- Secondary_Stack), or else an allocator to create the 5320 -- return object in the heap or user-defined pool 5321 -- (BIP_Alloc_Form = Global_Heap or User_Storage_Pool). 5322 5323 -- ??? An unchecked type conversion must be made in the 5324 -- case of assigning the access object formal to the 5325 -- local access object, because a normal conversion would 5326 -- be illegal in some cases (such as converting access- 5327 -- to-unconstrained to access-to-constrained), but the 5328 -- the unchecked conversion will presumably fail to work 5329 -- right in just such cases. It's not clear at all how to 5330 -- handle this. ??? 5331 5332 Alloc_If_Stmt := 5333 Make_If_Statement (Loc, 5334 Condition => 5335 Make_Op_Eq (Loc, 5336 Left_Opnd => 5337 New_Occurrence_Of (Obj_Alloc_Formal, Loc), 5338 Right_Opnd => 5339 Make_Integer_Literal (Loc, 5340 UI_From_Int (BIP_Allocation_Form'Pos 5341 (Caller_Allocation)))), 5342 5343 Then_Statements => New_List ( 5344 Make_Assignment_Statement (Loc, 5345 Name => 5346 New_Occurrence_Of (Alloc_Obj_Id, Loc), 5347 Expression => 5348 Make_Unchecked_Type_Conversion (Loc, 5349 Subtype_Mark => 5350 New_Occurrence_Of (Ref_Type, Loc), 5351 Expression => 5352 New_Occurrence_Of (Obj_Acc_Formal, Loc)))), 5353 5354 Elsif_Parts => New_List ( 5355 Make_Elsif_Part (Loc, 5356 Condition => 5357 Make_Op_Eq (Loc, 5358 Left_Opnd => 5359 New_Occurrence_Of (Obj_Alloc_Formal, Loc), 5360 Right_Opnd => 5361 Make_Integer_Literal (Loc, 5362 UI_From_Int (BIP_Allocation_Form'Pos 5363 (Secondary_Stack)))), 5364 5365 Then_Statements => New_List ( 5366 Make_Assignment_Statement (Loc, 5367 Name => 5368 New_Occurrence_Of (Alloc_Obj_Id, Loc), 5369 Expression => SS_Allocator))), 5370 5371 Make_Elsif_Part (Loc, 5372 Condition => 5373 Make_Op_Eq (Loc, 5374 Left_Opnd => 5375 New_Occurrence_Of (Obj_Alloc_Formal, Loc), 5376 Right_Opnd => 5377 Make_Integer_Literal (Loc, 5378 UI_From_Int (BIP_Allocation_Form'Pos 5379 (Global_Heap)))), 5380 5381 Then_Statements => New_List ( 5382 Build_Heap_Or_Pool_Allocator 5383 (Temp_Id => Alloc_Obj_Id, 5384 Temp_Typ => Ref_Type, 5385 Func_Id => Func_Id, 5386 Ret_Typ => Ret_Obj_Typ, 5387 Alloc_Expr => Heap_Allocator))), 5388 5389 -- ???If all is well, we can put the following 5390 -- 'elsif' in the 'else', but this is a useful 5391 -- self-check in case caller and callee don't agree 5392 -- on whether BIPAlloc and so on should be passed. 5393 5394 Make_Elsif_Part (Loc, 5395 Condition => 5396 Make_Op_Eq (Loc, 5397 Left_Opnd => 5398 New_Occurrence_Of (Obj_Alloc_Formal, Loc), 5399 Right_Opnd => 5400 Make_Integer_Literal (Loc, 5401 UI_From_Int (BIP_Allocation_Form'Pos 5402 (User_Storage_Pool)))), 5403 5404 Then_Statements => New_List ( 5405 Pool_Decl, 5406 Build_Heap_Or_Pool_Allocator 5407 (Temp_Id => Alloc_Obj_Id, 5408 Temp_Typ => Ref_Type, 5409 Func_Id => Func_Id, 5410 Ret_Typ => Ret_Obj_Typ, 5411 Alloc_Expr => Pool_Allocator)))), 5412 5413 -- Raise Program_Error if it's none of the above; 5414 -- this is a compiler bug. 5415 5416 Else_Statements => New_List (Guard_Except)); 5417 5418 -- If a separate initialization assignment was created 5419 -- earlier, append that following the assignment of the 5420 -- implicit access formal to the access object, to ensure 5421 -- that the return object is initialized in that case. In 5422 -- this situation, the target of the assignment must be 5423 -- rewritten to denote a dereference of the access to the 5424 -- return object passed in by the caller. 5425 5426 if Present (Init_Assignment) then 5427 Rewrite (Name (Init_Assignment), 5428 Make_Explicit_Dereference (Loc, 5429 Prefix => New_Occurrence_Of (Alloc_Obj_Id, Loc))); 5430 pragma Assert 5431 (Assignment_OK 5432 (Original_Node (Name (Init_Assignment)))); 5433 Set_Assignment_OK (Name (Init_Assignment)); 5434 5435 Set_Etype (Name (Init_Assignment), Etype (Ret_Obj_Id)); 5436 5437 Append_To 5438 (Then_Statements (Alloc_If_Stmt), Init_Assignment); 5439 end if; 5440 5441 Insert_Before (Ret_Obj_Decl, Alloc_If_Stmt); 5442 5443 -- Remember the local access object for use in the 5444 -- dereference of the renaming created below. 5445 5446 Obj_Acc_Formal := Alloc_Obj_Id; 5447 end; 5448 end if; 5449 5450 -- Replace the return object declaration with a renaming of a 5451 -- dereference of the access value designating the return 5452 -- object. 5453 5454 Obj_Acc_Deref := 5455 Make_Explicit_Dereference (Loc, 5456 Prefix => New_Occurrence_Of (Obj_Acc_Formal, Loc)); 5457 5458 Rewrite (Ret_Obj_Decl, 5459 Make_Object_Renaming_Declaration (Loc, 5460 Defining_Identifier => Ret_Obj_Id, 5461 Access_Definition => Empty, 5462 Subtype_Mark => New_Occurrence_Of (Ret_Obj_Typ, Loc), 5463 Name => Obj_Acc_Deref)); 5464 5465 Set_Renamed_Object (Ret_Obj_Id, Obj_Acc_Deref); 5466 end; 5467 end if; 5468 5469 -- Case where we do not build a block 5470 5471 else 5472 -- We're about to drop Return_Object_Declarations on the floor, so 5473 -- we need to insert it, in case it got expanded into useful code. 5474 -- Remove side effects from expression, which may be duplicated in 5475 -- subsequent checks (see Expand_Simple_Function_Return). 5476 5477 Insert_List_Before (N, Return_Object_Declarations (N)); 5478 Remove_Side_Effects (Exp); 5479 5480 -- Build simple_return_statement that returns the expression directly 5481 5482 Return_Stmt := Make_Simple_Return_Statement (Loc, Expression => Exp); 5483 Result := Return_Stmt; 5484 end if; 5485 5486 -- Set the flag to prevent infinite recursion 5487 5488 Set_Comes_From_Extended_Return_Statement (Return_Stmt); 5489 5490 Rewrite (N, Result); 5491 Analyze (N, Suppress => All_Checks); 5492 end Expand_N_Extended_Return_Statement; 5493 5494 ---------------------------- 5495 -- Expand_N_Function_Call -- 5496 ---------------------------- 5497 5498 procedure Expand_N_Function_Call (N : Node_Id) is 5499 begin 5500 Expand_Call (N); 5501 end Expand_N_Function_Call; 5502 5503 --------------------------------------- 5504 -- Expand_N_Procedure_Call_Statement -- 5505 --------------------------------------- 5506 5507 procedure Expand_N_Procedure_Call_Statement (N : Node_Id) is 5508 begin 5509 Expand_Call (N); 5510 end Expand_N_Procedure_Call_Statement; 5511 5512 -------------------------------------- 5513 -- Expand_N_Simple_Return_Statement -- 5514 -------------------------------------- 5515 5516 procedure Expand_N_Simple_Return_Statement (N : Node_Id) is 5517 begin 5518 -- Defend against previous errors (i.e. the return statement calls a 5519 -- function that is not available in configurable runtime). 5520 5521 if Present (Expression (N)) 5522 and then Nkind (Expression (N)) = N_Empty 5523 then 5524 Check_Error_Detected; 5525 return; 5526 end if; 5527 5528 -- Distinguish the function and non-function cases: 5529 5530 case Ekind (Return_Applies_To (Return_Statement_Entity (N))) is 5531 when E_Function 5532 | E_Generic_Function 5533 => 5534 Expand_Simple_Function_Return (N); 5535 5536 when E_Entry 5537 | E_Entry_Family 5538 | E_Generic_Procedure 5539 | E_Procedure 5540 | E_Return_Statement 5541 => 5542 Expand_Non_Function_Return (N); 5543 5544 when others => 5545 raise Program_Error; 5546 end case; 5547 5548 exception 5549 when RE_Not_Available => 5550 return; 5551 end Expand_N_Simple_Return_Statement; 5552 5553 ------------------------------ 5554 -- Expand_N_Subprogram_Body -- 5555 ------------------------------ 5556 5557 -- Add poll call if ATC polling is enabled, unless the body will be inlined 5558 -- by the back-end. 5559 5560 -- Add dummy push/pop label nodes at start and end to clear any local 5561 -- exception indications if local-exception-to-goto optimization is active. 5562 5563 -- Add return statement if last statement in body is not a return statement 5564 -- (this makes things easier on Gigi which does not want to have to handle 5565 -- a missing return). 5566 5567 -- Add call to Activate_Tasks if body is a task activator 5568 5569 -- Deal with possible detection of infinite recursion 5570 5571 -- Eliminate body completely if convention stubbed 5572 5573 -- Encode entity names within body, since we will not need to reference 5574 -- these entities any longer in the front end. 5575 5576 -- Initialize scalar out parameters if Initialize/Normalize_Scalars 5577 5578 -- Reset Pure indication if any parameter has root type System.Address 5579 -- or has any parameters of limited types, where limited means that the 5580 -- run-time view is limited (i.e. the full type is limited). 5581 5582 -- Wrap thread body 5583 5584 procedure Expand_N_Subprogram_Body (N : Node_Id) is 5585 Body_Id : constant Entity_Id := Defining_Entity (N); 5586 HSS : constant Node_Id := Handled_Statement_Sequence (N); 5587 Loc : constant Source_Ptr := Sloc (N); 5588 5589 procedure Add_Return (Spec_Id : Entity_Id; Stmts : List_Id); 5590 -- Append a return statement to the statement sequence Stmts if the last 5591 -- statement is not already a return or a goto statement. Note that the 5592 -- latter test is not critical, it does not matter if we add a few extra 5593 -- returns, since they get eliminated anyway later on. Spec_Id denotes 5594 -- the corresponding spec of the subprogram body. 5595 5596 ---------------- 5597 -- Add_Return -- 5598 ---------------- 5599 5600 procedure Add_Return (Spec_Id : Entity_Id; Stmts : List_Id) is 5601 Last_Stmt : Node_Id; 5602 Loc : Source_Ptr; 5603 Stmt : Node_Id; 5604 5605 begin 5606 -- Get last statement, ignoring any Pop_xxx_Label nodes, which are 5607 -- not relevant in this context since they are not executable. 5608 5609 Last_Stmt := Last (Stmts); 5610 while Nkind (Last_Stmt) in N_Pop_xxx_Label loop 5611 Prev (Last_Stmt); 5612 end loop; 5613 5614 -- Now insert return unless last statement is a transfer 5615 5616 if not Is_Transfer (Last_Stmt) then 5617 5618 -- The source location for the return is the end label of the 5619 -- procedure if present. Otherwise use the sloc of the last 5620 -- statement in the list. If the list comes from a generated 5621 -- exception handler and we are not debugging generated code, 5622 -- all the statements within the handler are made invisible 5623 -- to the debugger. 5624 5625 if Nkind (Parent (Stmts)) = N_Exception_Handler 5626 and then not Comes_From_Source (Parent (Stmts)) 5627 then 5628 Loc := Sloc (Last_Stmt); 5629 elsif Present (End_Label (HSS)) then 5630 Loc := Sloc (End_Label (HSS)); 5631 else 5632 Loc := Sloc (Last_Stmt); 5633 end if; 5634 5635 -- Append return statement, and set analyzed manually. We can't 5636 -- call Analyze on this return since the scope is wrong. 5637 5638 -- Note: it almost works to push the scope and then do the Analyze 5639 -- call, but something goes wrong in some weird cases and it is 5640 -- not worth worrying about ??? 5641 5642 Stmt := Make_Simple_Return_Statement (Loc); 5643 5644 -- The return statement is handled properly, and the call to the 5645 -- postcondition, inserted below, does not require information 5646 -- from the body either. However, that call is analyzed in the 5647 -- enclosing scope, and an elaboration check might improperly be 5648 -- added to it. A guard in Sem_Elab is needed to prevent that 5649 -- spurious check, see Check_Elab_Call. 5650 5651 Append_To (Stmts, Stmt); 5652 Set_Analyzed (Stmt); 5653 5654 -- Call the _Postconditions procedure if the related subprogram 5655 -- has contract assertions that need to be verified on exit. 5656 5657 if Ekind (Spec_Id) = E_Procedure 5658 and then Present (Postconditions_Proc (Spec_Id)) 5659 then 5660 Insert_Action (Stmt, 5661 Make_Procedure_Call_Statement (Loc, 5662 Name => 5663 New_Occurrence_Of (Postconditions_Proc (Spec_Id), Loc))); 5664 end if; 5665 end if; 5666 end Add_Return; 5667 5668 -- Local variables 5669 5670 Except_H : Node_Id; 5671 L : List_Id; 5672 Spec_Id : Entity_Id; 5673 5674 -- Start of processing for Expand_N_Subprogram_Body 5675 5676 begin 5677 if Present (Corresponding_Spec (N)) then 5678 Spec_Id := Corresponding_Spec (N); 5679 else 5680 Spec_Id := Body_Id; 5681 end if; 5682 5683 -- If this is a Pure function which has any parameters whose root type 5684 -- is System.Address, reset the Pure indication. 5685 -- This check is also performed when the subprogram is frozen, but we 5686 -- repeat it on the body so that the indication is consistent, and so 5687 -- it applies as well to bodies without separate specifications. 5688 5689 if Is_Pure (Spec_Id) 5690 and then Is_Subprogram (Spec_Id) 5691 and then not Has_Pragma_Pure_Function (Spec_Id) 5692 then 5693 Check_Function_With_Address_Parameter (Spec_Id); 5694 5695 if Spec_Id /= Body_Id then 5696 Set_Is_Pure (Body_Id, Is_Pure (Spec_Id)); 5697 end if; 5698 end if; 5699 5700 -- Set L to either the list of declarations if present, or to the list 5701 -- of statements if no declarations are present. This is used to insert 5702 -- new stuff at the start. 5703 5704 if Is_Non_Empty_List (Declarations (N)) then 5705 L := Declarations (N); 5706 else 5707 L := Statements (HSS); 5708 end if; 5709 5710 -- If local-exception-to-goto optimization active, insert dummy push 5711 -- statements at start, and dummy pop statements at end, but inhibit 5712 -- this if we have No_Exception_Handlers, since they are useless and 5713 -- interfere with analysis, e.g. by CodePeer. We also don't need these 5714 -- if we're unnesting subprograms because the only purpose of these 5715 -- nodes is to ensure we don't set a label in one subprogram and branch 5716 -- to it in another. 5717 5718 if (Debug_Flag_Dot_G 5719 or else Restriction_Active (No_Exception_Propagation)) 5720 and then not Restriction_Active (No_Exception_Handlers) 5721 and then not CodePeer_Mode 5722 and then not Unnest_Subprogram_Mode 5723 and then Is_Non_Empty_List (L) 5724 then 5725 declare 5726 FS : constant Node_Id := First (L); 5727 FL : constant Source_Ptr := Sloc (FS); 5728 LS : Node_Id; 5729 LL : Source_Ptr; 5730 5731 begin 5732 -- LS points to either last statement, if statements are present 5733 -- or to the last declaration if there are no statements present. 5734 -- It is the node after which the pop's are generated. 5735 5736 if Is_Non_Empty_List (Statements (HSS)) then 5737 LS := Last (Statements (HSS)); 5738 else 5739 LS := Last (L); 5740 end if; 5741 5742 LL := Sloc (LS); 5743 5744 Insert_List_Before_And_Analyze (FS, New_List ( 5745 Make_Push_Constraint_Error_Label (FL), 5746 Make_Push_Program_Error_Label (FL), 5747 Make_Push_Storage_Error_Label (FL))); 5748 5749 Insert_List_After_And_Analyze (LS, New_List ( 5750 Make_Pop_Constraint_Error_Label (LL), 5751 Make_Pop_Program_Error_Label (LL), 5752 Make_Pop_Storage_Error_Label (LL))); 5753 end; 5754 end if; 5755 5756 -- Need poll on entry to subprogram if polling enabled. We only do this 5757 -- for non-empty subprograms, since it does not seem necessary to poll 5758 -- for a dummy null subprogram. 5759 5760 if Is_Non_Empty_List (L) then 5761 5762 -- Do not add a polling call if the subprogram is to be inlined by 5763 -- the back-end, to avoid repeated calls with multiple inlinings. 5764 5765 if Is_Inlined (Spec_Id) 5766 and then Front_End_Inlining 5767 and then Optimization_Level > 1 5768 then 5769 null; 5770 else 5771 Generate_Poll_Call (First (L)); 5772 end if; 5773 end if; 5774 5775 -- Initialize any scalar OUT args if Initialize/Normalize_Scalars 5776 5777 if Init_Or_Norm_Scalars and then Is_Subprogram (Spec_Id) then 5778 declare 5779 F : Entity_Id; 5780 A : Node_Id; 5781 5782 begin 5783 -- Loop through formals 5784 5785 F := First_Formal (Spec_Id); 5786 while Present (F) loop 5787 if Is_Scalar_Type (Etype (F)) 5788 and then Ekind (F) = E_Out_Parameter 5789 then 5790 Check_Restriction (No_Default_Initialization, F); 5791 5792 -- Insert the initialization. We turn off validity checks 5793 -- for this assignment, since we do not want any check on 5794 -- the initial value itself (which may well be invalid). 5795 -- Predicate checks are disabled as well (RM 6.4.1 (13/3)) 5796 5797 A := 5798 Make_Assignment_Statement (Loc, 5799 Name => New_Occurrence_Of (F, Loc), 5800 Expression => Get_Simple_Init_Val (Etype (F), N)); 5801 Set_Suppress_Assignment_Checks (A); 5802 5803 Insert_Before_And_Analyze (First (L), 5804 A, Suppress => Validity_Check); 5805 end if; 5806 5807 Next_Formal (F); 5808 end loop; 5809 end; 5810 end if; 5811 5812 -- Clear out statement list for stubbed procedure 5813 5814 if Present (Corresponding_Spec (N)) then 5815 Set_Elaboration_Flag (N, Spec_Id); 5816 5817 if Convention (Spec_Id) = Convention_Stubbed 5818 or else Is_Eliminated (Spec_Id) 5819 then 5820 Set_Declarations (N, Empty_List); 5821 Set_Handled_Statement_Sequence (N, 5822 Make_Handled_Sequence_Of_Statements (Loc, 5823 Statements => New_List (Make_Null_Statement (Loc)))); 5824 5825 return; 5826 end if; 5827 end if; 5828 5829 -- Create a set of discriminals for the next protected subprogram body 5830 5831 if Is_List_Member (N) 5832 and then Present (Parent (List_Containing (N))) 5833 and then Nkind (Parent (List_Containing (N))) = N_Protected_Body 5834 and then Present (Next_Protected_Operation (N)) 5835 then 5836 Set_Discriminals (Parent (Base_Type (Scope (Spec_Id)))); 5837 end if; 5838 5839 -- Returns_By_Ref flag is normally set when the subprogram is frozen but 5840 -- subprograms with no specs are not frozen. 5841 5842 declare 5843 Typ : constant Entity_Id := Etype (Spec_Id); 5844 Utyp : constant Entity_Id := Underlying_Type (Typ); 5845 5846 begin 5847 if Is_Limited_View (Typ) then 5848 Set_Returns_By_Ref (Spec_Id); 5849 5850 elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then 5851 Set_Returns_By_Ref (Spec_Id); 5852 end if; 5853 end; 5854 5855 -- For a procedure, we add a return for all possible syntactic ends of 5856 -- the subprogram. 5857 5858 if Ekind_In (Spec_Id, E_Procedure, E_Generic_Procedure) then 5859 Add_Return (Spec_Id, Statements (HSS)); 5860 5861 if Present (Exception_Handlers (HSS)) then 5862 Except_H := First_Non_Pragma (Exception_Handlers (HSS)); 5863 while Present (Except_H) loop 5864 Add_Return (Spec_Id, Statements (Except_H)); 5865 Next_Non_Pragma (Except_H); 5866 end loop; 5867 end if; 5868 5869 -- For a function, we must deal with the case where there is at least 5870 -- one missing return. What we do is to wrap the entire body of the 5871 -- function in a block: 5872 5873 -- begin 5874 -- ... 5875 -- end; 5876 5877 -- becomes 5878 5879 -- begin 5880 -- begin 5881 -- ... 5882 -- end; 5883 5884 -- raise Program_Error; 5885 -- end; 5886 5887 -- This approach is necessary because the raise must be signalled to the 5888 -- caller, not handled by any local handler (RM 6.4(11)). 5889 5890 -- Note: we do not need to analyze the constructed sequence here, since 5891 -- it has no handler, and an attempt to analyze the handled statement 5892 -- sequence twice is risky in various ways (e.g. the issue of expanding 5893 -- cleanup actions twice). 5894 5895 elsif Has_Missing_Return (Spec_Id) then 5896 declare 5897 Hloc : constant Source_Ptr := Sloc (HSS); 5898 Blok : constant Node_Id := 5899 Make_Block_Statement (Hloc, 5900 Handled_Statement_Sequence => HSS); 5901 Rais : constant Node_Id := 5902 Make_Raise_Program_Error (Hloc, 5903 Reason => PE_Missing_Return); 5904 5905 begin 5906 Set_Handled_Statement_Sequence (N, 5907 Make_Handled_Sequence_Of_Statements (Hloc, 5908 Statements => New_List (Blok, Rais))); 5909 5910 Push_Scope (Spec_Id); 5911 Analyze (Blok); 5912 Analyze (Rais); 5913 Pop_Scope; 5914 end; 5915 end if; 5916 5917 -- If subprogram contains a parameterless recursive call, then we may 5918 -- have an infinite recursion, so see if we can generate code to check 5919 -- for this possibility if storage checks are not suppressed. 5920 5921 if Ekind (Spec_Id) = E_Procedure 5922 and then Has_Recursive_Call (Spec_Id) 5923 and then not Storage_Checks_Suppressed (Spec_Id) 5924 then 5925 Detect_Infinite_Recursion (N, Spec_Id); 5926 end if; 5927 5928 -- Set to encode entity names in package body before gigi is called 5929 5930 Qualify_Entity_Names (N); 5931 5932 -- If the body belongs to a nonabstract library-level source primitive 5933 -- of a tagged type, install an elaboration check which ensures that a 5934 -- dispatching call targeting the primitive will not execute the body 5935 -- without it being previously elaborated. 5936 5937 Install_Primitive_Elaboration_Check (N); 5938 end Expand_N_Subprogram_Body; 5939 5940 ----------------------------------- 5941 -- Expand_N_Subprogram_Body_Stub -- 5942 ----------------------------------- 5943 5944 procedure Expand_N_Subprogram_Body_Stub (N : Node_Id) is 5945 Bod : Node_Id; 5946 5947 begin 5948 if Present (Corresponding_Body (N)) then 5949 Bod := Unit_Declaration_Node (Corresponding_Body (N)); 5950 5951 -- The body may have been expanded already when it is analyzed 5952 -- through the subunit node. Do no expand again: it interferes 5953 -- with the construction of unnesting tables when generating C. 5954 5955 if not Analyzed (Bod) then 5956 Expand_N_Subprogram_Body (Bod); 5957 end if; 5958 5959 -- Add full qualification to entities that may be created late 5960 -- during unnesting. 5961 5962 Qualify_Entity_Names (N); 5963 end if; 5964 end Expand_N_Subprogram_Body_Stub; 5965 5966 ------------------------------------- 5967 -- Expand_N_Subprogram_Declaration -- 5968 ------------------------------------- 5969 5970 -- If the declaration appears within a protected body, it is a private 5971 -- operation of the protected type. We must create the corresponding 5972 -- protected subprogram an associated formals. For a normal protected 5973 -- operation, this is done when expanding the protected type declaration. 5974 5975 -- If the declaration is for a null procedure, emit null body 5976 5977 procedure Expand_N_Subprogram_Declaration (N : Node_Id) is 5978 Loc : constant Source_Ptr := Sloc (N); 5979 Subp : constant Entity_Id := Defining_Entity (N); 5980 5981 -- Local variables 5982 5983 Scop : constant Entity_Id := Scope (Subp); 5984 Prot_Bod : Node_Id; 5985 Prot_Decl : Node_Id; 5986 Prot_Id : Entity_Id; 5987 5988 -- Start of processing for Expand_N_Subprogram_Declaration 5989 5990 begin 5991 -- In SPARK, subprogram declarations are only allowed in package 5992 -- specifications. 5993 5994 if Nkind (Parent (N)) /= N_Package_Specification then 5995 if Nkind (Parent (N)) = N_Compilation_Unit then 5996 Check_SPARK_05_Restriction 5997 ("subprogram declaration is not a library item", N); 5998 5999 elsif Present (Next (N)) 6000 and then Nkind (Next (N)) = N_Pragma 6001 and then Get_Pragma_Id (Next (N)) = Pragma_Import 6002 then 6003 -- In SPARK, subprogram declarations are also permitted in 6004 -- declarative parts when immediately followed by a corresponding 6005 -- pragma Import. We only check here that there is some pragma 6006 -- Import. 6007 6008 null; 6009 else 6010 Check_SPARK_05_Restriction 6011 ("subprogram declaration is not allowed here", N); 6012 end if; 6013 end if; 6014 6015 -- Deal with case of protected subprogram. Do not generate protected 6016 -- operation if operation is flagged as eliminated. 6017 6018 if Is_List_Member (N) 6019 and then Present (Parent (List_Containing (N))) 6020 and then Nkind (Parent (List_Containing (N))) = N_Protected_Body 6021 and then Is_Protected_Type (Scop) 6022 then 6023 if No (Protected_Body_Subprogram (Subp)) 6024 and then not Is_Eliminated (Subp) 6025 then 6026 Prot_Decl := 6027 Make_Subprogram_Declaration (Loc, 6028 Specification => 6029 Build_Protected_Sub_Specification 6030 (N, Scop, Unprotected_Mode)); 6031 6032 -- The protected subprogram is declared outside of the protected 6033 -- body. Given that the body has frozen all entities so far, we 6034 -- analyze the subprogram and perform freezing actions explicitly. 6035 -- including the generation of an explicit freeze node, to ensure 6036 -- that gigi has the proper order of elaboration. 6037 -- If the body is a subunit, the insertion point is before the 6038 -- stub in the parent. 6039 6040 Prot_Bod := Parent (List_Containing (N)); 6041 6042 if Nkind (Parent (Prot_Bod)) = N_Subunit then 6043 Prot_Bod := Corresponding_Stub (Parent (Prot_Bod)); 6044 end if; 6045 6046 Insert_Before (Prot_Bod, Prot_Decl); 6047 Prot_Id := Defining_Unit_Name (Specification (Prot_Decl)); 6048 Set_Has_Delayed_Freeze (Prot_Id); 6049 6050 Push_Scope (Scope (Scop)); 6051 Analyze (Prot_Decl); 6052 Freeze_Before (N, Prot_Id); 6053 Set_Protected_Body_Subprogram (Subp, Prot_Id); 6054 6055 -- Create protected operation as well. Even though the operation 6056 -- is only accessible within the body, it is possible to make it 6057 -- available outside of the protected object by using 'Access to 6058 -- provide a callback, so build protected version in all cases. 6059 6060 Prot_Decl := 6061 Make_Subprogram_Declaration (Loc, 6062 Specification => 6063 Build_Protected_Sub_Specification (N, Scop, Protected_Mode)); 6064 Insert_Before (Prot_Bod, Prot_Decl); 6065 Analyze (Prot_Decl); 6066 6067 Pop_Scope; 6068 end if; 6069 6070 -- Ada 2005 (AI-348): Generate body for a null procedure. In most 6071 -- cases this is superfluous because calls to it will be automatically 6072 -- inlined, but we definitely need the body if preconditions for the 6073 -- procedure are present, or if performing coverage analysis. 6074 6075 elsif Nkind (Specification (N)) = N_Procedure_Specification 6076 and then Null_Present (Specification (N)) 6077 then 6078 declare 6079 Bod : constant Node_Id := Body_To_Inline (N); 6080 6081 begin 6082 Set_Has_Completion (Subp, False); 6083 Append_Freeze_Action (Subp, Bod); 6084 6085 -- The body now contains raise statements, so calls to it will 6086 -- not be inlined. 6087 6088 Set_Is_Inlined (Subp, False); 6089 end; 6090 end if; 6091 6092 -- When generating C code, transform a function that returns a 6093 -- constrained array type into a procedure with an out parameter 6094 -- that carries the return value. 6095 6096 -- We skip this transformation for unchecked conversions, since they 6097 -- are not needed by the C generator (and this also produces cleaner 6098 -- output). 6099 6100 if Modify_Tree_For_C 6101 and then Nkind (Specification (N)) = N_Function_Specification 6102 and then Is_Array_Type (Etype (Subp)) 6103 and then Is_Constrained (Etype (Subp)) 6104 and then not Is_Unchecked_Conversion_Instance (Subp) 6105 then 6106 Build_Procedure_Form (N); 6107 end if; 6108 end Expand_N_Subprogram_Declaration; 6109 6110 -------------------------------- 6111 -- Expand_Non_Function_Return -- 6112 -------------------------------- 6113 6114 procedure Expand_Non_Function_Return (N : Node_Id) is 6115 pragma Assert (No (Expression (N))); 6116 6117 Loc : constant Source_Ptr := Sloc (N); 6118 Scope_Id : Entity_Id := Return_Applies_To (Return_Statement_Entity (N)); 6119 Kind : constant Entity_Kind := Ekind (Scope_Id); 6120 Call : Node_Id; 6121 Acc_Stat : Node_Id; 6122 Goto_Stat : Node_Id; 6123 Lab_Node : Node_Id; 6124 6125 begin 6126 -- Call the _Postconditions procedure if the related subprogram has 6127 -- contract assertions that need to be verified on exit. 6128 6129 if Ekind_In (Scope_Id, E_Entry, E_Entry_Family, E_Procedure) 6130 and then Present (Postconditions_Proc (Scope_Id)) 6131 then 6132 Insert_Action (N, 6133 Make_Procedure_Call_Statement (Loc, 6134 Name => New_Occurrence_Of (Postconditions_Proc (Scope_Id), Loc))); 6135 end if; 6136 6137 -- If it is a return from a procedure do no extra steps 6138 6139 if Kind = E_Procedure or else Kind = E_Generic_Procedure then 6140 return; 6141 6142 -- If it is a nested return within an extended one, replace it with a 6143 -- return of the previously declared return object. 6144 6145 elsif Kind = E_Return_Statement then 6146 Rewrite (N, 6147 Make_Simple_Return_Statement (Loc, 6148 Expression => 6149 New_Occurrence_Of (First_Entity (Scope_Id), Loc))); 6150 Set_Comes_From_Extended_Return_Statement (N); 6151 Set_Return_Statement_Entity (N, Scope_Id); 6152 Expand_Simple_Function_Return (N); 6153 return; 6154 end if; 6155 6156 pragma Assert (Is_Entry (Scope_Id)); 6157 6158 -- Look at the enclosing block to see whether the return is from an 6159 -- accept statement or an entry body. 6160 6161 for J in reverse 0 .. Scope_Stack.Last loop 6162 Scope_Id := Scope_Stack.Table (J).Entity; 6163 exit when Is_Concurrent_Type (Scope_Id); 6164 end loop; 6165 6166 -- If it is a return from accept statement it is expanded as call to 6167 -- RTS Complete_Rendezvous and a goto to the end of the accept body. 6168 6169 -- (cf : Expand_N_Accept_Statement, Expand_N_Selective_Accept, 6170 -- Expand_N_Accept_Alternative in exp_ch9.adb) 6171 6172 if Is_Task_Type (Scope_Id) then 6173 6174 Call := 6175 Make_Procedure_Call_Statement (Loc, 6176 Name => New_Occurrence_Of (RTE (RE_Complete_Rendezvous), Loc)); 6177 Insert_Before (N, Call); 6178 -- why not insert actions here??? 6179 Analyze (Call); 6180 6181 Acc_Stat := Parent (N); 6182 while Nkind (Acc_Stat) /= N_Accept_Statement loop 6183 Acc_Stat := Parent (Acc_Stat); 6184 end loop; 6185 6186 Lab_Node := Last (Statements 6187 (Handled_Statement_Sequence (Acc_Stat))); 6188 6189 Goto_Stat := Make_Goto_Statement (Loc, 6190 Name => New_Occurrence_Of 6191 (Entity (Identifier (Lab_Node)), Loc)); 6192 6193 Set_Analyzed (Goto_Stat); 6194 6195 Rewrite (N, Goto_Stat); 6196 Analyze (N); 6197 6198 -- If it is a return from an entry body, put a Complete_Entry_Body call 6199 -- in front of the return. 6200 6201 elsif Is_Protected_Type (Scope_Id) then 6202 Call := 6203 Make_Procedure_Call_Statement (Loc, 6204 Name => 6205 New_Occurrence_Of (RTE (RE_Complete_Entry_Body), Loc), 6206 Parameter_Associations => New_List ( 6207 Make_Attribute_Reference (Loc, 6208 Prefix => 6209 New_Occurrence_Of 6210 (Find_Protection_Object (Current_Scope), Loc), 6211 Attribute_Name => Name_Unchecked_Access))); 6212 6213 Insert_Before (N, Call); 6214 Analyze (Call); 6215 end if; 6216 end Expand_Non_Function_Return; 6217 6218 --------------------------------------- 6219 -- Expand_Protected_Object_Reference -- 6220 --------------------------------------- 6221 6222 function Expand_Protected_Object_Reference 6223 (N : Node_Id; 6224 Scop : Entity_Id) return Node_Id 6225 is 6226 Loc : constant Source_Ptr := Sloc (N); 6227 Corr : Entity_Id; 6228 Rec : Node_Id; 6229 Param : Entity_Id; 6230 Proc : Entity_Id; 6231 6232 begin 6233 Rec := Make_Identifier (Loc, Name_uObject); 6234 Set_Etype (Rec, Corresponding_Record_Type (Scop)); 6235 6236 -- Find enclosing protected operation, and retrieve its first parameter, 6237 -- which denotes the enclosing protected object. If the enclosing 6238 -- operation is an entry, we are immediately within the protected body, 6239 -- and we can retrieve the object from the service entries procedure. A 6240 -- barrier function has the same signature as an entry. A barrier 6241 -- function is compiled within the protected object, but unlike 6242 -- protected operations its never needs locks, so that its protected 6243 -- body subprogram points to itself. 6244 6245 Proc := Current_Scope; 6246 while Present (Proc) 6247 and then Scope (Proc) /= Scop 6248 loop 6249 Proc := Scope (Proc); 6250 end loop; 6251 6252 Corr := Protected_Body_Subprogram (Proc); 6253 6254 if No (Corr) then 6255 6256 -- Previous error left expansion incomplete. 6257 -- Nothing to do on this call. 6258 6259 return Empty; 6260 end if; 6261 6262 Param := 6263 Defining_Identifier 6264 (First (Parameter_Specifications (Parent (Corr)))); 6265 6266 if Is_Subprogram (Proc) and then Proc /= Corr then 6267 6268 -- Protected function or procedure 6269 6270 Set_Entity (Rec, Param); 6271 6272 -- Rec is a reference to an entity which will not be in scope when 6273 -- the call is reanalyzed, and needs no further analysis. 6274 6275 Set_Analyzed (Rec); 6276 6277 else 6278 -- Entry or barrier function for entry body. The first parameter of 6279 -- the entry body procedure is pointer to the object. We create a 6280 -- local variable of the proper type, duplicating what is done to 6281 -- define _object later on. 6282 6283 declare 6284 Decls : List_Id; 6285 Obj_Ptr : constant Entity_Id := Make_Temporary (Loc, 'T'); 6286 6287 begin 6288 Decls := New_List ( 6289 Make_Full_Type_Declaration (Loc, 6290 Defining_Identifier => Obj_Ptr, 6291 Type_Definition => 6292 Make_Access_To_Object_Definition (Loc, 6293 Subtype_Indication => 6294 New_Occurrence_Of 6295 (Corresponding_Record_Type (Scop), Loc)))); 6296 6297 Insert_Actions (N, Decls); 6298 Freeze_Before (N, Obj_Ptr); 6299 6300 Rec := 6301 Make_Explicit_Dereference (Loc, 6302 Prefix => 6303 Unchecked_Convert_To (Obj_Ptr, 6304 New_Occurrence_Of (Param, Loc))); 6305 6306 -- Analyze new actual. Other actuals in calls are already analyzed 6307 -- and the list of actuals is not reanalyzed after rewriting. 6308 6309 Set_Parent (Rec, N); 6310 Analyze (Rec); 6311 end; 6312 end if; 6313 6314 return Rec; 6315 end Expand_Protected_Object_Reference; 6316 6317 -------------------------------------- 6318 -- Expand_Protected_Subprogram_Call -- 6319 -------------------------------------- 6320 6321 procedure Expand_Protected_Subprogram_Call 6322 (N : Node_Id; 6323 Subp : Entity_Id; 6324 Scop : Entity_Id) 6325 is 6326 Rec : Node_Id; 6327 6328 procedure Expand_Internal_Init_Call; 6329 -- A call to an operation of the type may occur in the initialization 6330 -- of a private component. In that case the prefix of the call is an 6331 -- entity name and the call is treated as internal even though it 6332 -- appears in code outside of the protected type. 6333 6334 procedure Freeze_Called_Function; 6335 -- If it is a function call it can appear in elaboration code and 6336 -- the called entity must be frozen before the call. This must be 6337 -- done before the call is expanded, as the expansion may rewrite it 6338 -- to something other than a call (e.g. a temporary initialized in a 6339 -- transient block). 6340 6341 ------------------------------- 6342 -- Expand_Internal_Init_Call -- 6343 ------------------------------- 6344 6345 procedure Expand_Internal_Init_Call is 6346 begin 6347 -- If the context is a protected object (rather than a protected 6348 -- type) the call itself is bound to raise program_error because 6349 -- the protected body will not have been elaborated yet. This is 6350 -- diagnosed subsequently in Sem_Elab. 6351 6352 Freeze_Called_Function; 6353 6354 -- The target of the internal call is the first formal of the 6355 -- enclosing initialization procedure. 6356 6357 Rec := New_Occurrence_Of (First_Formal (Current_Scope), Sloc (N)); 6358 Build_Protected_Subprogram_Call (N, 6359 Name => Name (N), 6360 Rec => Rec, 6361 External => False); 6362 Analyze (N); 6363 Resolve (N, Etype (Subp)); 6364 end Expand_Internal_Init_Call; 6365 6366 ---------------------------- 6367 -- Freeze_Called_Function -- 6368 ---------------------------- 6369 6370 procedure Freeze_Called_Function is 6371 begin 6372 if Ekind (Subp) = E_Function then 6373 Freeze_Expression (Name (N)); 6374 end if; 6375 end Freeze_Called_Function; 6376 6377 -- Start of processing for Expand_Protected_Subprogram_Call 6378 6379 begin 6380 -- If the protected object is not an enclosing scope, this is an inter- 6381 -- object function call. Inter-object procedure calls are expanded by 6382 -- Exp_Ch9.Build_Simple_Entry_Call. The call is intra-object only if the 6383 -- subprogram being called is in the protected body being compiled, and 6384 -- if the protected object in the call is statically the enclosing type. 6385 -- The object may be a component of some other data structure, in which 6386 -- case this must be handled as an inter-object call. 6387 6388 if not In_Open_Scopes (Scop) 6389 or else Is_Entry_Wrapper (Current_Scope) 6390 or else not Is_Entity_Name (Name (N)) 6391 then 6392 if Nkind (Name (N)) = N_Selected_Component then 6393 Rec := Prefix (Name (N)); 6394 6395 elsif Nkind (Name (N)) = N_Indexed_Component then 6396 Rec := Prefix (Prefix (Name (N))); 6397 6398 -- If this is a call within an entry wrapper, it appears within a 6399 -- precondition that calls another primitive of the synchronized 6400 -- type. The target object of the call is the first actual on the 6401 -- wrapper. Note that this is an external call, because the wrapper 6402 -- is called outside of the synchronized object. This means that 6403 -- an entry call to an entry with preconditions involves two 6404 -- synchronized operations. 6405 6406 elsif Ekind (Current_Scope) = E_Procedure 6407 and then Is_Entry_Wrapper (Current_Scope) 6408 then 6409 Rec := New_Occurrence_Of (First_Entity (Current_Scope), Sloc (N)); 6410 6411 -- A default parameter of a protected operation may be a call to 6412 -- a protected function of the type. This appears as an internal 6413 -- call in the profile of the operation, but if the context is an 6414 -- external call we must convert the call into an external one, 6415 -- using the protected object that is the target, so that: 6416 6417 -- Prot.P (F) 6418 -- is transformed into 6419 -- Prot.P (Prot.F) 6420 6421 elsif Nkind (Parent (N)) = N_Procedure_Call_Statement 6422 and then Nkind (Name (Parent (N))) = N_Selected_Component 6423 and then Is_Protected_Type (Etype (Prefix (Name (Parent (N))))) 6424 and then Is_Entity_Name (Name (N)) 6425 and then Scope (Entity (Name (N))) = 6426 Etype (Prefix (Name (Parent (N)))) 6427 then 6428 Rewrite (Name (N), 6429 Make_Selected_Component (Sloc (N), 6430 Prefix => New_Copy_Tree (Prefix (Name (Parent (N)))), 6431 Selector_Name => Relocate_Node (Name (N)))); 6432 6433 Analyze_And_Resolve (N); 6434 return; 6435 6436 else 6437 -- If the context is the initialization procedure for a protected 6438 -- type, the call is legal because the called entity must be a 6439 -- function of that enclosing type, and this is treated as an 6440 -- internal call. 6441 6442 pragma Assert 6443 (Is_Entity_Name (Name (N)) and then Inside_Init_Proc); 6444 6445 Expand_Internal_Init_Call; 6446 return; 6447 end if; 6448 6449 Freeze_Called_Function; 6450 Build_Protected_Subprogram_Call (N, 6451 Name => New_Occurrence_Of (Subp, Sloc (N)), 6452 Rec => Convert_Concurrent (Rec, Etype (Rec)), 6453 External => True); 6454 6455 else 6456 Rec := Expand_Protected_Object_Reference (N, Scop); 6457 6458 if No (Rec) then 6459 return; 6460 end if; 6461 6462 Freeze_Called_Function; 6463 Build_Protected_Subprogram_Call (N, 6464 Name => Name (N), 6465 Rec => Rec, 6466 External => False); 6467 end if; 6468 6469 -- Analyze and resolve the new call. The actuals have already been 6470 -- resolved, but expansion of a function call will add extra actuals 6471 -- if needed. Analysis of a procedure call already includes resolution. 6472 6473 Analyze (N); 6474 6475 if Ekind (Subp) = E_Function then 6476 Resolve (N, Etype (Subp)); 6477 end if; 6478 end Expand_Protected_Subprogram_Call; 6479 6480 ----------------------------------- 6481 -- Expand_Simple_Function_Return -- 6482 ----------------------------------- 6483 6484 -- The "simple" comes from the syntax rule simple_return_statement. The 6485 -- semantics are not at all simple. 6486 6487 procedure Expand_Simple_Function_Return (N : Node_Id) is 6488 Loc : constant Source_Ptr := Sloc (N); 6489 6490 Scope_Id : constant Entity_Id := 6491 Return_Applies_To (Return_Statement_Entity (N)); 6492 -- The function we are returning from 6493 6494 R_Type : constant Entity_Id := Etype (Scope_Id); 6495 -- The result type of the function 6496 6497 Utyp : constant Entity_Id := Underlying_Type (R_Type); 6498 6499 Exp : Node_Id := Expression (N); 6500 pragma Assert (Present (Exp)); 6501 6502 Exptyp : constant Entity_Id := Etype (Exp); 6503 -- The type of the expression (not necessarily the same as R_Type) 6504 6505 Subtype_Ind : Node_Id; 6506 -- If the result type of the function is class-wide and the expression 6507 -- has a specific type, then we use the expression's type as the type of 6508 -- the return object. In cases where the expression is an aggregate that 6509 -- is built in place, this avoids the need for an expensive conversion 6510 -- of the return object to the specific type on assignments to the 6511 -- individual components. 6512 6513 begin 6514 if Is_Class_Wide_Type (R_Type) 6515 and then not Is_Class_Wide_Type (Exptyp) 6516 and then Nkind (Exp) /= N_Type_Conversion 6517 then 6518 Subtype_Ind := New_Occurrence_Of (Exptyp, Loc); 6519 else 6520 Subtype_Ind := New_Occurrence_Of (R_Type, Loc); 6521 6522 -- If the result type is class-wide and the expression is a view 6523 -- conversion, the conversion plays no role in the expansion because 6524 -- it does not modify the tag of the object. Remove the conversion 6525 -- altogether to prevent tag overwriting. 6526 6527 if Is_Class_Wide_Type (R_Type) 6528 and then not Is_Class_Wide_Type (Exptyp) 6529 and then Nkind (Exp) = N_Type_Conversion 6530 then 6531 Exp := Expression (Exp); 6532 end if; 6533 end if; 6534 6535 -- Assert that if F says "return G(...);" 6536 -- then F and G are both b-i-p, or neither b-i-p. 6537 6538 if Nkind (Exp) = N_Function_Call then 6539 pragma Assert (Ekind (Scope_Id) = E_Function); 6540 pragma Assert 6541 (Is_Build_In_Place_Function (Scope_Id) = 6542 Is_Build_In_Place_Function_Call (Exp)); 6543 null; 6544 end if; 6545 6546 -- For the case of a simple return that does not come from an 6547 -- extended return, in the case of build-in-place, we rewrite 6548 -- "return <expression>;" to be: 6549 6550 -- return _anon_ : <return_subtype> := <expression> 6551 6552 -- The expansion produced by Expand_N_Extended_Return_Statement will 6553 -- contain simple return statements (for example, a block containing 6554 -- simple return of the return object), which brings us back here with 6555 -- Comes_From_Extended_Return_Statement set. The reason for the barrier 6556 -- checking for a simple return that does not come from an extended 6557 -- return is to avoid this infinite recursion. 6558 6559 -- The reason for this design is that for Ada 2005 limited returns, we 6560 -- need to reify the return object, so we can build it "in place", and 6561 -- we need a block statement to hang finalization and tasking stuff. 6562 6563 -- ??? In order to avoid disruption, we avoid translating to extended 6564 -- return except in the cases where we really need to (Ada 2005 for 6565 -- inherently limited). We might prefer to do this translation in all 6566 -- cases (except perhaps for the case of Ada 95 inherently limited), 6567 -- in order to fully exercise the Expand_N_Extended_Return_Statement 6568 -- code. This would also allow us to do the build-in-place optimization 6569 -- for efficiency even in cases where it is semantically not required. 6570 6571 -- As before, we check the type of the return expression rather than the 6572 -- return type of the function, because the latter may be a limited 6573 -- class-wide interface type, which is not a limited type, even though 6574 -- the type of the expression may be. 6575 6576 pragma Assert 6577 (Comes_From_Extended_Return_Statement (N) 6578 or else not Is_Build_In_Place_Function_Call (Exp) 6579 or else Is_Build_In_Place_Function (Scope_Id)); 6580 6581 if not Comes_From_Extended_Return_Statement (N) 6582 and then Is_Build_In_Place_Function (Scope_Id) 6583 and then not Debug_Flag_Dot_L 6584 6585 -- The functionality of interface thunks is simple and it is always 6586 -- handled by means of simple return statements. This leaves their 6587 -- expansion simple and clean. 6588 6589 and then not Is_Thunk (Current_Scope) 6590 then 6591 declare 6592 Return_Object_Entity : constant Entity_Id := 6593 Make_Temporary (Loc, 'R', Exp); 6594 6595 Obj_Decl : constant Node_Id := 6596 Make_Object_Declaration (Loc, 6597 Defining_Identifier => Return_Object_Entity, 6598 Object_Definition => Subtype_Ind, 6599 Expression => Exp); 6600 6601 Ext : constant Node_Id := 6602 Make_Extended_Return_Statement (Loc, 6603 Return_Object_Declarations => New_List (Obj_Decl)); 6604 -- Do not perform this high-level optimization if the result type 6605 -- is an interface because the "this" pointer must be displaced. 6606 6607 begin 6608 Rewrite (N, Ext); 6609 Analyze (N); 6610 return; 6611 end; 6612 end if; 6613 6614 -- Here we have a simple return statement that is part of the expansion 6615 -- of an extended return statement (either written by the user, or 6616 -- generated by the above code). 6617 6618 -- Always normalize C/Fortran boolean result. This is not always needed, 6619 -- but it seems a good idea to minimize the passing around of non- 6620 -- normalized values, and in any case this handles the processing of 6621 -- barrier functions for protected types, which turn the condition into 6622 -- a return statement. 6623 6624 if Is_Boolean_Type (Exptyp) 6625 and then Nonzero_Is_True (Exptyp) 6626 then 6627 Adjust_Condition (Exp); 6628 Adjust_Result_Type (Exp, Exptyp); 6629 end if; 6630 6631 -- Do validity check if enabled for returns 6632 6633 if Validity_Checks_On 6634 and then Validity_Check_Returns 6635 then 6636 Ensure_Valid (Exp); 6637 end if; 6638 6639 -- Check the result expression of a scalar function against the subtype 6640 -- of the function by inserting a conversion. This conversion must 6641 -- eventually be performed for other classes of types, but for now it's 6642 -- only done for scalars. 6643 -- ??? 6644 6645 if Is_Scalar_Type (Exptyp) then 6646 Rewrite (Exp, Convert_To (R_Type, Exp)); 6647 6648 -- The expression is resolved to ensure that the conversion gets 6649 -- expanded to generate a possible constraint check. 6650 6651 Analyze_And_Resolve (Exp, R_Type); 6652 end if; 6653 6654 -- Deal with returning variable length objects and controlled types 6655 6656 -- Nothing to do if we are returning by reference, or this is not a 6657 -- type that requires special processing (indicated by the fact that 6658 -- it requires a cleanup scope for the secondary stack case). 6659 6660 if Is_Build_In_Place_Function (Scope_Id) 6661 or else Is_Limited_Interface (Exptyp) 6662 then 6663 null; 6664 6665 -- No copy needed for thunks returning interface type objects since 6666 -- the object is returned by reference and the maximum functionality 6667 -- required is just to displace the pointer. 6668 6669 elsif Is_Thunk (Current_Scope) and then Is_Interface (Exptyp) then 6670 null; 6671 6672 -- If the call is within a thunk and the type is a limited view, the 6673 -- backend will eventually see the non-limited view of the type. 6674 6675 elsif Is_Thunk (Current_Scope) and then Is_Incomplete_Type (Exptyp) then 6676 return; 6677 6678 elsif not Requires_Transient_Scope (R_Type) then 6679 6680 -- Mutable records with variable-length components are not returned 6681 -- on the sec-stack, so we need to make sure that the back end will 6682 -- only copy back the size of the actual value, and not the maximum 6683 -- size. We create an actual subtype for this purpose. However we 6684 -- need not do it if the expression is a function call since this 6685 -- will be done in the called function and doing it here too would 6686 -- cause a temporary with maximum size to be created. 6687 6688 declare 6689 Ubt : constant Entity_Id := Underlying_Type (Base_Type (Exptyp)); 6690 Decl : Node_Id; 6691 Ent : Entity_Id; 6692 begin 6693 if Nkind (Exp) /= N_Function_Call 6694 and then Has_Discriminants (Ubt) 6695 and then not Is_Constrained (Ubt) 6696 and then not Has_Unchecked_Union (Ubt) 6697 then 6698 Decl := Build_Actual_Subtype (Ubt, Exp); 6699 Ent := Defining_Identifier (Decl); 6700 Insert_Action (Exp, Decl); 6701 Rewrite (Exp, Unchecked_Convert_To (Ent, Exp)); 6702 Analyze_And_Resolve (Exp); 6703 end if; 6704 end; 6705 6706 -- Here if secondary stack is used 6707 6708 else 6709 -- Prevent the reclamation of the secondary stack by all enclosing 6710 -- blocks and loops as well as the related function; otherwise the 6711 -- result would be reclaimed too early. 6712 6713 Set_Enclosing_Sec_Stack_Return (N); 6714 6715 -- Optimize the case where the result is a function call. In this 6716 -- case either the result is already on the secondary stack, or is 6717 -- already being returned with the stack pointer depressed and no 6718 -- further processing is required except to set the By_Ref flag 6719 -- to ensure that gigi does not attempt an extra unnecessary copy. 6720 -- (actually not just unnecessary but harmfully wrong in the case 6721 -- of a controlled type, where gigi does not know how to do a copy). 6722 -- To make up for a gcc 2.8.1 deficiency (???), we perform the copy 6723 -- for array types if the constrained status of the target type is 6724 -- different from that of the expression. 6725 6726 if Requires_Transient_Scope (Exptyp) 6727 and then 6728 (not Is_Array_Type (Exptyp) 6729 or else Is_Constrained (Exptyp) = Is_Constrained (R_Type) 6730 or else CW_Or_Has_Controlled_Part (Utyp)) 6731 and then Nkind (Exp) = N_Function_Call 6732 then 6733 Set_By_Ref (N); 6734 6735 -- Remove side effects from the expression now so that other parts 6736 -- of the expander do not have to reanalyze this node without this 6737 -- optimization 6738 6739 Rewrite (Exp, Duplicate_Subexpr_No_Checks (Exp)); 6740 6741 -- Ada 2005 (AI-251): If the type of the returned object is 6742 -- an interface then add an implicit type conversion to force 6743 -- displacement of the "this" pointer. 6744 6745 if Is_Interface (R_Type) then 6746 Rewrite (Exp, Convert_To (R_Type, Relocate_Node (Exp))); 6747 end if; 6748 6749 Analyze_And_Resolve (Exp, R_Type); 6750 6751 -- For controlled types, do the allocation on the secondary stack 6752 -- manually in order to call adjust at the right time: 6753 6754 -- type Anon1 is access R_Type; 6755 -- for Anon1'Storage_pool use ss_pool; 6756 -- Anon2 : anon1 := new R_Type'(expr); 6757 -- return Anon2.all; 6758 6759 -- We do the same for classwide types that are not potentially 6760 -- controlled (by the virtue of restriction No_Finalization) because 6761 -- gigi is not able to properly allocate class-wide types. 6762 6763 elsif CW_Or_Has_Controlled_Part (Utyp) then 6764 declare 6765 Loc : constant Source_Ptr := Sloc (N); 6766 Acc_Typ : constant Entity_Id := Make_Temporary (Loc, 'A'); 6767 Alloc_Node : Node_Id; 6768 Temp : Entity_Id; 6769 6770 begin 6771 Set_Ekind (Acc_Typ, E_Access_Type); 6772 6773 Set_Associated_Storage_Pool (Acc_Typ, RTE (RE_SS_Pool)); 6774 6775 -- This is an allocator for the secondary stack, and it's fine 6776 -- to have Comes_From_Source set False on it, as gigi knows not 6777 -- to flag it as a violation of No_Implicit_Heap_Allocations. 6778 6779 Alloc_Node := 6780 Make_Allocator (Loc, 6781 Expression => 6782 Make_Qualified_Expression (Loc, 6783 Subtype_Mark => New_Occurrence_Of (Etype (Exp), Loc), 6784 Expression => Relocate_Node (Exp))); 6785 6786 -- We do not want discriminant checks on the declaration, 6787 -- given that it gets its value from the allocator. 6788 6789 Set_No_Initialization (Alloc_Node); 6790 6791 Temp := Make_Temporary (Loc, 'R', Alloc_Node); 6792 6793 Insert_List_Before_And_Analyze (N, New_List ( 6794 Make_Full_Type_Declaration (Loc, 6795 Defining_Identifier => Acc_Typ, 6796 Type_Definition => 6797 Make_Access_To_Object_Definition (Loc, 6798 Subtype_Indication => Subtype_Ind)), 6799 6800 Make_Object_Declaration (Loc, 6801 Defining_Identifier => Temp, 6802 Object_Definition => New_Occurrence_Of (Acc_Typ, Loc), 6803 Expression => Alloc_Node))); 6804 6805 Rewrite (Exp, 6806 Make_Explicit_Dereference (Loc, 6807 Prefix => New_Occurrence_Of (Temp, Loc))); 6808 6809 -- Ada 2005 (AI-251): If the type of the returned object is 6810 -- an interface then add an implicit type conversion to force 6811 -- displacement of the "this" pointer. 6812 6813 if Is_Interface (R_Type) then 6814 Rewrite (Exp, Convert_To (R_Type, Relocate_Node (Exp))); 6815 end if; 6816 6817 Analyze_And_Resolve (Exp, R_Type); 6818 end; 6819 6820 -- Otherwise use the gigi mechanism to allocate result on the 6821 -- secondary stack. 6822 6823 else 6824 Check_Restriction (No_Secondary_Stack, N); 6825 Set_Storage_Pool (N, RTE (RE_SS_Pool)); 6826 Set_Procedure_To_Call (N, RTE (RE_SS_Allocate)); 6827 end if; 6828 end if; 6829 6830 -- Implement the rules of 6.5(8-10), which require a tag check in 6831 -- the case of a limited tagged return type, and tag reassignment for 6832 -- nonlimited tagged results. These actions are needed when the return 6833 -- type is a specific tagged type and the result expression is a 6834 -- conversion or a formal parameter, because in that case the tag of 6835 -- the expression might differ from the tag of the specific result type. 6836 6837 -- We must also verify an underlying type exists for the return type in 6838 -- case it is incomplete - in which case is not necessary to generate a 6839 -- check anyway since an incomplete limited tagged return type would 6840 -- qualify as a premature usage. 6841 6842 if Present (Utyp) 6843 and then Is_Tagged_Type (Utyp) 6844 and then not Is_Class_Wide_Type (Utyp) 6845 and then (Nkind_In (Exp, N_Type_Conversion, 6846 N_Unchecked_Type_Conversion) 6847 or else (Is_Entity_Name (Exp) 6848 and then Is_Formal (Entity (Exp)))) 6849 then 6850 -- When the return type is limited, perform a check that the tag of 6851 -- the result is the same as the tag of the return type. 6852 6853 if Is_Limited_Type (R_Type) then 6854 Insert_Action (Exp, 6855 Make_Raise_Constraint_Error (Loc, 6856 Condition => 6857 Make_Op_Ne (Loc, 6858 Left_Opnd => 6859 Make_Selected_Component (Loc, 6860 Prefix => Duplicate_Subexpr (Exp), 6861 Selector_Name => Make_Identifier (Loc, Name_uTag)), 6862 Right_Opnd => 6863 Make_Attribute_Reference (Loc, 6864 Prefix => 6865 New_Occurrence_Of (Base_Type (Utyp), Loc), 6866 Attribute_Name => Name_Tag)), 6867 Reason => CE_Tag_Check_Failed)); 6868 6869 -- If the result type is a specific nonlimited tagged type, then we 6870 -- have to ensure that the tag of the result is that of the result 6871 -- type. This is handled by making a copy of the expression in 6872 -- the case where it might have a different tag, namely when the 6873 -- expression is a conversion or a formal parameter. We create a new 6874 -- object of the result type and initialize it from the expression, 6875 -- which will implicitly force the tag to be set appropriately. 6876 6877 else 6878 declare 6879 ExpR : constant Node_Id := Relocate_Node (Exp); 6880 Result_Id : constant Entity_Id := 6881 Make_Temporary (Loc, 'R', ExpR); 6882 Result_Exp : constant Node_Id := 6883 New_Occurrence_Of (Result_Id, Loc); 6884 Result_Obj : constant Node_Id := 6885 Make_Object_Declaration (Loc, 6886 Defining_Identifier => Result_Id, 6887 Object_Definition => 6888 New_Occurrence_Of (R_Type, Loc), 6889 Constant_Present => True, 6890 Expression => ExpR); 6891 6892 begin 6893 Set_Assignment_OK (Result_Obj); 6894 Insert_Action (Exp, Result_Obj); 6895 6896 Rewrite (Exp, Result_Exp); 6897 Analyze_And_Resolve (Exp, R_Type); 6898 end; 6899 end if; 6900 6901 -- Ada 2005 (AI-344): If the result type is class-wide, then insert 6902 -- a check that the level of the return expression's underlying type 6903 -- is not deeper than the level of the master enclosing the function. 6904 -- Always generate the check when the type of the return expression 6905 -- is class-wide, when it's a type conversion, or when it's a formal 6906 -- parameter. Otherwise, suppress the check in the case where the 6907 -- return expression has a specific type whose level is known not to 6908 -- be statically deeper than the function's result type. 6909 6910 -- No runtime check needed in interface thunks since it is performed 6911 -- by the target primitive associated with the thunk. 6912 6913 -- Note: accessibility check is skipped in the VM case, since there 6914 -- does not seem to be any practical way to implement this check. 6915 6916 elsif Ada_Version >= Ada_2005 6917 and then Tagged_Type_Expansion 6918 and then Is_Class_Wide_Type (R_Type) 6919 and then not Is_Thunk (Current_Scope) 6920 and then not Scope_Suppress.Suppress (Accessibility_Check) 6921 and then 6922 (Is_Class_Wide_Type (Etype (Exp)) 6923 or else Nkind_In (Exp, N_Type_Conversion, 6924 N_Unchecked_Type_Conversion) 6925 or else (Is_Entity_Name (Exp) 6926 and then Is_Formal (Entity (Exp))) 6927 or else Scope_Depth (Enclosing_Dynamic_Scope (Etype (Exp))) > 6928 Scope_Depth (Enclosing_Dynamic_Scope (Scope_Id))) 6929 then 6930 declare 6931 Tag_Node : Node_Id; 6932 6933 begin 6934 -- Ada 2005 (AI-251): In class-wide interface objects we displace 6935 -- "this" to reference the base of the object. This is required to 6936 -- get access to the TSD of the object. 6937 6938 if Is_Class_Wide_Type (Etype (Exp)) 6939 and then Is_Interface (Etype (Exp)) 6940 then 6941 -- If the expression is an explicit dereference then we can 6942 -- directly displace the pointer to reference the base of 6943 -- the object. 6944 6945 if Nkind (Exp) = N_Explicit_Dereference then 6946 Tag_Node := 6947 Make_Explicit_Dereference (Loc, 6948 Prefix => 6949 Unchecked_Convert_To (RTE (RE_Tag_Ptr), 6950 Make_Function_Call (Loc, 6951 Name => 6952 New_Occurrence_Of (RTE (RE_Base_Address), Loc), 6953 Parameter_Associations => New_List ( 6954 Unchecked_Convert_To (RTE (RE_Address), 6955 Duplicate_Subexpr (Prefix (Exp))))))); 6956 6957 -- Similar case to the previous one but the expression is a 6958 -- renaming of an explicit dereference. 6959 6960 elsif Nkind (Exp) = N_Identifier 6961 and then Present (Renamed_Object (Entity (Exp))) 6962 and then Nkind (Renamed_Object (Entity (Exp))) 6963 = N_Explicit_Dereference 6964 then 6965 Tag_Node := 6966 Make_Explicit_Dereference (Loc, 6967 Prefix => 6968 Unchecked_Convert_To (RTE (RE_Tag_Ptr), 6969 Make_Function_Call (Loc, 6970 Name => 6971 New_Occurrence_Of (RTE (RE_Base_Address), Loc), 6972 Parameter_Associations => New_List ( 6973 Unchecked_Convert_To (RTE (RE_Address), 6974 Duplicate_Subexpr 6975 (Prefix 6976 (Renamed_Object (Entity (Exp))))))))); 6977 6978 -- Common case: obtain the address of the actual object and 6979 -- displace the pointer to reference the base of the object. 6980 6981 else 6982 Tag_Node := 6983 Make_Explicit_Dereference (Loc, 6984 Prefix => 6985 Unchecked_Convert_To (RTE (RE_Tag_Ptr), 6986 Make_Function_Call (Loc, 6987 Name => 6988 New_Occurrence_Of (RTE (RE_Base_Address), Loc), 6989 Parameter_Associations => New_List ( 6990 Make_Attribute_Reference (Loc, 6991 Prefix => Duplicate_Subexpr (Exp), 6992 Attribute_Name => Name_Address))))); 6993 end if; 6994 else 6995 Tag_Node := 6996 Make_Attribute_Reference (Loc, 6997 Prefix => Duplicate_Subexpr (Exp), 6998 Attribute_Name => Name_Tag); 6999 end if; 7000 7001 -- CodePeer does not do anything useful with 7002 -- Ada.Tags.Type_Specific_Data components. 7003 7004 if not CodePeer_Mode then 7005 Insert_Action (Exp, 7006 Make_Raise_Program_Error (Loc, 7007 Condition => 7008 Make_Op_Gt (Loc, 7009 Left_Opnd => Build_Get_Access_Level (Loc, Tag_Node), 7010 Right_Opnd => 7011 Make_Integer_Literal (Loc, 7012 Scope_Depth (Enclosing_Dynamic_Scope (Scope_Id)))), 7013 Reason => PE_Accessibility_Check_Failed)); 7014 end if; 7015 end; 7016 7017 -- AI05-0073: If function has a controlling access result, check that 7018 -- the tag of the return value, if it is not null, matches designated 7019 -- type of return type. 7020 7021 -- The return expression is referenced twice in the code below, so it 7022 -- must be made free of side effects. Given that different compilers 7023 -- may evaluate these parameters in different order, both occurrences 7024 -- perform a copy. 7025 7026 elsif Ekind (R_Type) = E_Anonymous_Access_Type 7027 and then Has_Controlling_Result (Scope_Id) 7028 then 7029 Insert_Action (N, 7030 Make_Raise_Constraint_Error (Loc, 7031 Condition => 7032 Make_And_Then (Loc, 7033 Left_Opnd => 7034 Make_Op_Ne (Loc, 7035 Left_Opnd => Duplicate_Subexpr (Exp), 7036 Right_Opnd => Make_Null (Loc)), 7037 7038 Right_Opnd => Make_Op_Ne (Loc, 7039 Left_Opnd => 7040 Make_Selected_Component (Loc, 7041 Prefix => Duplicate_Subexpr (Exp), 7042 Selector_Name => Make_Identifier (Loc, Name_uTag)), 7043 7044 Right_Opnd => 7045 Make_Attribute_Reference (Loc, 7046 Prefix => 7047 New_Occurrence_Of (Designated_Type (R_Type), Loc), 7048 Attribute_Name => Name_Tag))), 7049 7050 Reason => CE_Tag_Check_Failed), 7051 Suppress => All_Checks); 7052 end if; 7053 7054 -- AI05-0234: RM 6.5(21/3). Check access discriminants to 7055 -- ensure that the function result does not outlive an 7056 -- object designated by one of it discriminants. 7057 7058 if Present (Extra_Accessibility_Of_Result (Scope_Id)) 7059 and then Has_Unconstrained_Access_Discriminants (R_Type) 7060 then 7061 declare 7062 Discrim_Source : Node_Id; 7063 7064 procedure Check_Against_Result_Level (Level : Node_Id); 7065 -- Check the given accessibility level against the level 7066 -- determined by the point of call. (AI05-0234). 7067 7068 -------------------------------- 7069 -- Check_Against_Result_Level -- 7070 -------------------------------- 7071 7072 procedure Check_Against_Result_Level (Level : Node_Id) is 7073 begin 7074 Insert_Action (N, 7075 Make_Raise_Program_Error (Loc, 7076 Condition => 7077 Make_Op_Gt (Loc, 7078 Left_Opnd => Level, 7079 Right_Opnd => 7080 New_Occurrence_Of 7081 (Extra_Accessibility_Of_Result (Scope_Id), Loc)), 7082 Reason => PE_Accessibility_Check_Failed)); 7083 end Check_Against_Result_Level; 7084 7085 begin 7086 Discrim_Source := Exp; 7087 while Nkind (Discrim_Source) = N_Qualified_Expression loop 7088 Discrim_Source := Expression (Discrim_Source); 7089 end loop; 7090 7091 if Nkind (Discrim_Source) = N_Identifier 7092 and then Is_Return_Object (Entity (Discrim_Source)) 7093 then 7094 Discrim_Source := Entity (Discrim_Source); 7095 7096 if Is_Constrained (Etype (Discrim_Source)) then 7097 Discrim_Source := Etype (Discrim_Source); 7098 else 7099 Discrim_Source := Expression (Parent (Discrim_Source)); 7100 end if; 7101 7102 elsif Nkind (Discrim_Source) = N_Identifier 7103 and then Nkind_In (Original_Node (Discrim_Source), 7104 N_Aggregate, N_Extension_Aggregate) 7105 then 7106 Discrim_Source := Original_Node (Discrim_Source); 7107 7108 elsif Nkind (Discrim_Source) = N_Explicit_Dereference and then 7109 Nkind (Original_Node (Discrim_Source)) = N_Function_Call 7110 then 7111 Discrim_Source := Original_Node (Discrim_Source); 7112 end if; 7113 7114 Discrim_Source := Unqual_Conv (Discrim_Source); 7115 7116 case Nkind (Discrim_Source) is 7117 when N_Defining_Identifier => 7118 pragma Assert (Is_Composite_Type (Discrim_Source) 7119 and then Has_Discriminants (Discrim_Source) 7120 and then Is_Constrained (Discrim_Source)); 7121 7122 declare 7123 Discrim : Entity_Id := 7124 First_Discriminant (Base_Type (R_Type)); 7125 Disc_Elmt : Elmt_Id := 7126 First_Elmt (Discriminant_Constraint 7127 (Discrim_Source)); 7128 begin 7129 loop 7130 if Ekind (Etype (Discrim)) = 7131 E_Anonymous_Access_Type 7132 then 7133 Check_Against_Result_Level 7134 (Dynamic_Accessibility_Level (Node (Disc_Elmt))); 7135 end if; 7136 7137 Next_Elmt (Disc_Elmt); 7138 Next_Discriminant (Discrim); 7139 exit when not Present (Discrim); 7140 end loop; 7141 end; 7142 7143 when N_Aggregate 7144 | N_Extension_Aggregate 7145 => 7146 -- Unimplemented: extension aggregate case where discrims 7147 -- come from ancestor part, not extension part. 7148 7149 declare 7150 Discrim : Entity_Id := 7151 First_Discriminant (Base_Type (R_Type)); 7152 7153 Disc_Exp : Node_Id := Empty; 7154 7155 Positionals_Exhausted 7156 : Boolean := not Present (Expressions 7157 (Discrim_Source)); 7158 7159 function Associated_Expr 7160 (Comp_Id : Entity_Id; 7161 Associations : List_Id) return Node_Id; 7162 7163 -- Given a component and a component associations list, 7164 -- locate the expression for that component; returns 7165 -- Empty if no such expression is found. 7166 7167 --------------------- 7168 -- Associated_Expr -- 7169 --------------------- 7170 7171 function Associated_Expr 7172 (Comp_Id : Entity_Id; 7173 Associations : List_Id) return Node_Id 7174 is 7175 Assoc : Node_Id; 7176 Choice : Node_Id; 7177 7178 begin 7179 -- Simple linear search seems ok here 7180 7181 Assoc := First (Associations); 7182 while Present (Assoc) loop 7183 Choice := First (Choices (Assoc)); 7184 while Present (Choice) loop 7185 if (Nkind (Choice) = N_Identifier 7186 and then Chars (Choice) = Chars (Comp_Id)) 7187 or else (Nkind (Choice) = N_Others_Choice) 7188 then 7189 return Expression (Assoc); 7190 end if; 7191 7192 Next (Choice); 7193 end loop; 7194 7195 Next (Assoc); 7196 end loop; 7197 7198 return Empty; 7199 end Associated_Expr; 7200 7201 begin 7202 if not Positionals_Exhausted then 7203 Disc_Exp := First (Expressions (Discrim_Source)); 7204 end if; 7205 7206 loop 7207 if Positionals_Exhausted then 7208 Disc_Exp := 7209 Associated_Expr 7210 (Discrim, 7211 Component_Associations (Discrim_Source)); 7212 end if; 7213 7214 if Ekind (Etype (Discrim)) = 7215 E_Anonymous_Access_Type 7216 then 7217 Check_Against_Result_Level 7218 (Dynamic_Accessibility_Level (Disc_Exp)); 7219 end if; 7220 7221 Next_Discriminant (Discrim); 7222 exit when not Present (Discrim); 7223 7224 if not Positionals_Exhausted then 7225 Next (Disc_Exp); 7226 Positionals_Exhausted := not Present (Disc_Exp); 7227 end if; 7228 end loop; 7229 end; 7230 7231 when N_Function_Call => 7232 7233 -- No check needed (check performed by callee) 7234 7235 null; 7236 7237 when others => 7238 declare 7239 Level : constant Node_Id := 7240 Make_Integer_Literal (Loc, 7241 Object_Access_Level (Discrim_Source)); 7242 7243 begin 7244 -- Unimplemented: check for name prefix that includes 7245 -- a dereference of an access value with a dynamic 7246 -- accessibility level (e.g., an access param or a 7247 -- saooaaat) and use dynamic level in that case. For 7248 -- example: 7249 -- return Access_Param.all(Some_Index).Some_Component; 7250 -- ??? 7251 7252 Set_Etype (Level, Standard_Natural); 7253 Check_Against_Result_Level (Level); 7254 end; 7255 end case; 7256 end; 7257 end if; 7258 7259 -- If we are returning an object that may not be bit-aligned, then copy 7260 -- the value into a temporary first. This copy may need to expand to a 7261 -- loop of component operations. 7262 7263 if Is_Possibly_Unaligned_Slice (Exp) 7264 or else Is_Possibly_Unaligned_Object (Exp) 7265 then 7266 declare 7267 ExpR : constant Node_Id := Relocate_Node (Exp); 7268 Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', ExpR); 7269 begin 7270 Insert_Action (Exp, 7271 Make_Object_Declaration (Loc, 7272 Defining_Identifier => Tnn, 7273 Constant_Present => True, 7274 Object_Definition => New_Occurrence_Of (R_Type, Loc), 7275 Expression => ExpR), 7276 Suppress => All_Checks); 7277 Rewrite (Exp, New_Occurrence_Of (Tnn, Loc)); 7278 end; 7279 end if; 7280 7281 -- Call the _Postconditions procedure if the related function has 7282 -- contract assertions that need to be verified on exit. 7283 7284 if Ekind (Scope_Id) = E_Function 7285 and then Present (Postconditions_Proc (Scope_Id)) 7286 then 7287 -- In the case of discriminated objects, we have created a 7288 -- constrained subtype above, and used the underlying type. This 7289 -- transformation is post-analysis and harmless, except that now the 7290 -- call to the post-condition will be analyzed and the type kinds 7291 -- have to match. 7292 7293 if Nkind (Exp) = N_Unchecked_Type_Conversion 7294 and then Is_Private_Type (R_Type) /= Is_Private_Type (Etype (Exp)) 7295 then 7296 Rewrite (Exp, Expression (Relocate_Node (Exp))); 7297 end if; 7298 7299 -- We are going to reference the returned value twice in this case, 7300 -- once in the call to _Postconditions, and once in the actual return 7301 -- statement, but we can't have side effects happening twice. 7302 7303 Force_Evaluation (Exp, Mode => Strict); 7304 7305 -- Generate call to _Postconditions 7306 7307 Insert_Action (Exp, 7308 Make_Procedure_Call_Statement (Loc, 7309 Name => 7310 New_Occurrence_Of (Postconditions_Proc (Scope_Id), Loc), 7311 Parameter_Associations => New_List (New_Copy_Tree (Exp)))); 7312 end if; 7313 7314 -- Ada 2005 (AI-251): If this return statement corresponds with an 7315 -- simple return statement associated with an extended return statement 7316 -- and the type of the returned object is an interface then generate an 7317 -- implicit conversion to force displacement of the "this" pointer. 7318 7319 if Ada_Version >= Ada_2005 7320 and then Comes_From_Extended_Return_Statement (N) 7321 and then Nkind (Expression (N)) = N_Identifier 7322 and then Is_Interface (Utyp) 7323 and then Utyp /= Underlying_Type (Exptyp) 7324 then 7325 Rewrite (Exp, Convert_To (Utyp, Relocate_Node (Exp))); 7326 Analyze_And_Resolve (Exp); 7327 end if; 7328 end Expand_Simple_Function_Return; 7329 7330 ----------------------- 7331 -- Freeze_Subprogram -- 7332 ----------------------- 7333 7334 procedure Freeze_Subprogram (N : Node_Id) is 7335 Loc : constant Source_Ptr := Sloc (N); 7336 7337 procedure Register_Predefined_DT_Entry (Prim : Entity_Id); 7338 -- (Ada 2005): Register a predefined primitive in all the secondary 7339 -- dispatch tables of its primitive type. 7340 7341 ---------------------------------- 7342 -- Register_Predefined_DT_Entry -- 7343 ---------------------------------- 7344 7345 procedure Register_Predefined_DT_Entry (Prim : Entity_Id) is 7346 Iface_DT_Ptr : Elmt_Id; 7347 Tagged_Typ : Entity_Id; 7348 Thunk_Id : Entity_Id; 7349 Thunk_Code : Node_Id; 7350 7351 begin 7352 Tagged_Typ := Find_Dispatching_Type (Prim); 7353 7354 if No (Access_Disp_Table (Tagged_Typ)) 7355 or else not Has_Interfaces (Tagged_Typ) 7356 or else not RTE_Available (RE_Interface_Tag) 7357 or else Restriction_Active (No_Dispatching_Calls) 7358 then 7359 return; 7360 end if; 7361 7362 -- Skip the first two access-to-dispatch-table pointers since they 7363 -- leads to the primary dispatch table (predefined DT and user 7364 -- defined DT). We are only concerned with the secondary dispatch 7365 -- table pointers. Note that the access-to- dispatch-table pointer 7366 -- corresponds to the first implemented interface retrieved below. 7367 7368 Iface_DT_Ptr := 7369 Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Tagged_Typ)))); 7370 7371 while Present (Iface_DT_Ptr) 7372 and then Ekind (Node (Iface_DT_Ptr)) = E_Constant 7373 loop 7374 pragma Assert (Has_Thunks (Node (Iface_DT_Ptr))); 7375 Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code); 7376 7377 if Present (Thunk_Code) then 7378 Insert_Actions_After (N, New_List ( 7379 Thunk_Code, 7380 7381 Build_Set_Predefined_Prim_Op_Address (Loc, 7382 Tag_Node => 7383 New_Occurrence_Of (Node (Next_Elmt (Iface_DT_Ptr)), Loc), 7384 Position => DT_Position (Prim), 7385 Address_Node => 7386 Unchecked_Convert_To (RTE (RE_Prim_Ptr), 7387 Make_Attribute_Reference (Loc, 7388 Prefix => New_Occurrence_Of (Thunk_Id, Loc), 7389 Attribute_Name => Name_Unrestricted_Access))), 7390 7391 Build_Set_Predefined_Prim_Op_Address (Loc, 7392 Tag_Node => 7393 New_Occurrence_Of 7394 (Node (Next_Elmt (Next_Elmt (Next_Elmt (Iface_DT_Ptr)))), 7395 Loc), 7396 Position => DT_Position (Prim), 7397 Address_Node => 7398 Unchecked_Convert_To (RTE (RE_Prim_Ptr), 7399 Make_Attribute_Reference (Loc, 7400 Prefix => New_Occurrence_Of (Prim, Loc), 7401 Attribute_Name => Name_Unrestricted_Access))))); 7402 end if; 7403 7404 -- Skip the tag of the predefined primitives dispatch table 7405 7406 Next_Elmt (Iface_DT_Ptr); 7407 pragma Assert (Has_Thunks (Node (Iface_DT_Ptr))); 7408 7409 -- Skip tag of the no-thunks dispatch table 7410 7411 Next_Elmt (Iface_DT_Ptr); 7412 pragma Assert (not Has_Thunks (Node (Iface_DT_Ptr))); 7413 7414 -- Skip tag of predefined primitives no-thunks dispatch table 7415 7416 Next_Elmt (Iface_DT_Ptr); 7417 pragma Assert (not Has_Thunks (Node (Iface_DT_Ptr))); 7418 7419 Next_Elmt (Iface_DT_Ptr); 7420 end loop; 7421 end Register_Predefined_DT_Entry; 7422 7423 -- Local variables 7424 7425 Subp : constant Entity_Id := Entity (N); 7426 7427 -- Start of processing for Freeze_Subprogram 7428 7429 begin 7430 -- We suppress the initialization of the dispatch table entry when 7431 -- not Tagged_Type_Expansion because the dispatching mechanism is 7432 -- handled internally by the target. 7433 7434 if Is_Dispatching_Operation (Subp) 7435 and then not Is_Abstract_Subprogram (Subp) 7436 and then Present (DTC_Entity (Subp)) 7437 and then Present (Scope (DTC_Entity (Subp))) 7438 and then Tagged_Type_Expansion 7439 and then not Restriction_Active (No_Dispatching_Calls) 7440 and then RTE_Available (RE_Tag) 7441 then 7442 declare 7443 Typ : constant Entity_Id := Scope (DTC_Entity (Subp)); 7444 7445 begin 7446 -- Handle private overridden primitives 7447 7448 if not Is_CPP_Class (Typ) then 7449 Check_Overriding_Operation (Subp); 7450 end if; 7451 7452 -- We assume that imported CPP primitives correspond with objects 7453 -- whose constructor is in the CPP side; therefore we don't need 7454 -- to generate code to register them in the dispatch table. 7455 7456 if Is_CPP_Class (Typ) then 7457 null; 7458 7459 -- Handle CPP primitives found in derivations of CPP_Class types. 7460 -- These primitives must have been inherited from some parent, and 7461 -- there is no need to register them in the dispatch table because 7462 -- Build_Inherit_Prims takes care of initializing these slots. 7463 7464 elsif Is_Imported (Subp) 7465 and then (Convention (Subp) = Convention_CPP 7466 or else Convention (Subp) = Convention_C) 7467 then 7468 null; 7469 7470 -- Generate code to register the primitive in non statically 7471 -- allocated dispatch tables 7472 7473 elsif not Building_Static_DT (Scope (DTC_Entity (Subp))) then 7474 7475 -- When a primitive is frozen, enter its name in its dispatch 7476 -- table slot. 7477 7478 if not Is_Interface (Typ) 7479 or else Present (Interface_Alias (Subp)) 7480 then 7481 if Is_Predefined_Dispatching_Operation (Subp) then 7482 Register_Predefined_DT_Entry (Subp); 7483 end if; 7484 7485 Insert_Actions_After (N, 7486 Register_Primitive (Loc, Prim => Subp)); 7487 end if; 7488 end if; 7489 end; 7490 end if; 7491 7492 -- Mark functions that return by reference. Note that it cannot be part 7493 -- of the normal semantic analysis of the spec since the underlying 7494 -- returned type may not be known yet (for private types). 7495 7496 declare 7497 Typ : constant Entity_Id := Etype (Subp); 7498 Utyp : constant Entity_Id := Underlying_Type (Typ); 7499 7500 begin 7501 if Is_Limited_View (Typ) then 7502 Set_Returns_By_Ref (Subp); 7503 7504 elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then 7505 Set_Returns_By_Ref (Subp); 7506 end if; 7507 end; 7508 7509 -- Wnen freezing a null procedure, analyze its delayed aspects now 7510 -- because we may not have reached the end of the declarative list when 7511 -- delayed aspects are normally analyzed. This ensures that dispatching 7512 -- calls are properly rewritten when the generated _Postcondition 7513 -- procedure is analyzed in the null procedure body. 7514 7515 if Nkind (Parent (Subp)) = N_Procedure_Specification 7516 and then Null_Present (Parent (Subp)) 7517 then 7518 Analyze_Entry_Or_Subprogram_Contract (Subp); 7519 end if; 7520 end Freeze_Subprogram; 7521 7522 -------------------------------------------- 7523 -- Has_Unconstrained_Access_Discriminants -- 7524 -------------------------------------------- 7525 7526 function Has_Unconstrained_Access_Discriminants 7527 (Subtyp : Entity_Id) return Boolean 7528 is 7529 Discr : Entity_Id; 7530 7531 begin 7532 if Has_Discriminants (Subtyp) 7533 and then not Is_Constrained (Subtyp) 7534 then 7535 Discr := First_Discriminant (Subtyp); 7536 while Present (Discr) loop 7537 if Ekind (Etype (Discr)) = E_Anonymous_Access_Type then 7538 return True; 7539 end if; 7540 7541 Next_Discriminant (Discr); 7542 end loop; 7543 end if; 7544 7545 return False; 7546 end Has_Unconstrained_Access_Discriminants; 7547 7548 ------------------------------ 7549 -- Insert_Post_Call_Actions -- 7550 ------------------------------ 7551 7552 procedure Insert_Post_Call_Actions (N : Node_Id; Post_Call : List_Id) is 7553 Context : constant Node_Id := Parent (N); 7554 7555 begin 7556 if Is_Empty_List (Post_Call) then 7557 return; 7558 end if; 7559 7560 -- Cases where the call is not a member of a statement list. This 7561 -- includes the case where the call is an actual in another function 7562 -- call or indexing, i.e. an expression context as well. 7563 7564 if not Is_List_Member (N) 7565 or else Nkind_In (Context, N_Function_Call, N_Indexed_Component) 7566 then 7567 -- In Ada 2012 the call may be a function call in an expression 7568 -- (since OUT and IN OUT parameters are now allowed for such calls). 7569 -- The write-back of (in)-out parameters is handled by the back-end, 7570 -- but the constraint checks generated when subtypes of formal and 7571 -- actual don't match must be inserted in the form of assignments. 7572 7573 if Nkind (Original_Node (N)) = N_Function_Call then 7574 pragma Assert (Ada_Version >= Ada_2012); 7575 -- Functions with '[in] out' parameters are only allowed in Ada 7576 -- 2012. 7577 7578 -- We used to handle this by climbing up parents to a 7579 -- non-statement/declaration and then simply making a call to 7580 -- Insert_Actions_After (P, Post_Call), but that doesn't work 7581 -- for Ada 2012. If we are in the middle of an expression, e.g. 7582 -- the condition of an IF, this call would insert after the IF 7583 -- statement, which is much too late to be doing the write back. 7584 -- For example: 7585 7586 -- if Clobber (X) then 7587 -- Put_Line (X'Img); 7588 -- else 7589 -- goto Junk 7590 -- end if; 7591 7592 -- Now assume Clobber changes X, if we put the write back after 7593 -- the IF, the Put_Line gets the wrong value and the goto causes 7594 -- the write back to be skipped completely. 7595 7596 -- To deal with this, we replace the call by 7597 7598 -- do 7599 -- Tnnn : constant function-result-type := function-call; 7600 -- Post_Call actions 7601 -- in 7602 -- Tnnn; 7603 -- end; 7604 7605 declare 7606 Loc : constant Source_Ptr := Sloc (N); 7607 Tnnn : constant Entity_Id := Make_Temporary (Loc, 'T'); 7608 FRTyp : constant Entity_Id := Etype (N); 7609 Name : constant Node_Id := Relocate_Node (N); 7610 7611 begin 7612 Prepend_To (Post_Call, 7613 Make_Object_Declaration (Loc, 7614 Defining_Identifier => Tnnn, 7615 Object_Definition => New_Occurrence_Of (FRTyp, Loc), 7616 Constant_Present => True, 7617 Expression => Name)); 7618 7619 Rewrite (N, 7620 Make_Expression_With_Actions (Loc, 7621 Actions => Post_Call, 7622 Expression => New_Occurrence_Of (Tnnn, Loc))); 7623 7624 -- We don't want to just blindly call Analyze_And_Resolve 7625 -- because that would cause unwanted recursion on the call. 7626 -- So for a moment set the call as analyzed to prevent that 7627 -- recursion, and get the rest analyzed properly, then reset 7628 -- the analyzed flag, so our caller can continue. 7629 7630 Set_Analyzed (Name, True); 7631 Analyze_And_Resolve (N, FRTyp); 7632 Set_Analyzed (Name, False); 7633 end; 7634 7635 -- If not the special Ada 2012 case of a function call, then we must 7636 -- have the triggering statement of a triggering alternative or an 7637 -- entry call alternative, and we can add the post call stuff to the 7638 -- corresponding statement list. 7639 7640 else 7641 pragma Assert (Nkind_In (Context, N_Entry_Call_Alternative, 7642 N_Triggering_Alternative)); 7643 7644 if Is_Non_Empty_List (Statements (Context)) then 7645 Insert_List_Before_And_Analyze 7646 (First (Statements (Context)), Post_Call); 7647 else 7648 Set_Statements (Context, Post_Call); 7649 end if; 7650 end if; 7651 7652 -- A procedure call is always part of a declarative or statement list, 7653 -- however a function call may appear nested within a construct. Most 7654 -- cases of function call nesting are handled in the special case above. 7655 -- The only exception is when the function call acts as an actual in a 7656 -- procedure call. In this case the function call is in a list, but the 7657 -- post-call actions must be inserted after the procedure call. 7658 7659 elsif Nkind (Context) = N_Procedure_Call_Statement then 7660 Insert_Actions_After (Context, Post_Call); 7661 7662 -- Otherwise, normal case where N is in a statement sequence, just put 7663 -- the post-call stuff after the call statement. 7664 7665 else 7666 Insert_Actions_After (N, Post_Call); 7667 end if; 7668 end Insert_Post_Call_Actions; 7669 7670 ----------------------------------- 7671 -- Is_Build_In_Place_Result_Type -- 7672 ----------------------------------- 7673 7674 function Is_Build_In_Place_Result_Type (Typ : Entity_Id) return Boolean is 7675 begin 7676 if not Expander_Active then 7677 return False; 7678 end if; 7679 7680 -- In Ada 2005 all functions with an inherently limited return type 7681 -- must be handled using a build-in-place profile, including the case 7682 -- of a function with a limited interface result, where the function 7683 -- may return objects of nonlimited descendants. 7684 7685 if Is_Limited_View (Typ) then 7686 return Ada_Version >= Ada_2005 and then not Debug_Flag_Dot_L; 7687 7688 else 7689 if Debug_Flag_Dot_9 then 7690 return False; 7691 end if; 7692 7693 if Has_Interfaces (Typ) then 7694 return False; 7695 end if; 7696 7697 declare 7698 T : Entity_Id := Typ; 7699 begin 7700 -- For T'Class, return True if it's True for T. This is necessary 7701 -- because a class-wide function might say "return F (...)", where 7702 -- F returns the corresponding specific type. We need a loop in 7703 -- case T is a subtype of a class-wide type. 7704 7705 while Is_Class_Wide_Type (T) loop 7706 T := Etype (T); 7707 end loop; 7708 7709 -- If this is a generic formal type in an instance, return True if 7710 -- it's True for the generic actual type. 7711 7712 if Nkind (Parent (T)) = N_Subtype_Declaration 7713 and then Present (Generic_Parent_Type (Parent (T))) 7714 then 7715 T := Entity (Subtype_Indication (Parent (T))); 7716 7717 if Present (Full_View (T)) then 7718 T := Full_View (T); 7719 end if; 7720 end if; 7721 7722 if Present (Underlying_Type (T)) then 7723 T := Underlying_Type (T); 7724 end if; 7725 7726 declare 7727 Result : Boolean; 7728 -- So we can stop here in the debugger 7729 begin 7730 -- ???For now, enable build-in-place for a very narrow set of 7731 -- controlled types. Change "if True" to "if False" to 7732 -- experiment with more controlled types. Eventually, we might 7733 -- like to enable build-in-place for all tagged types, all 7734 -- types that need finalization, and all caller-unknown-size 7735 -- types. 7736 7737 if True then 7738 Result := Is_Controlled (T) 7739 and then Present (Enclosing_Subprogram (T)) 7740 and then not Is_Compilation_Unit (Enclosing_Subprogram (T)) 7741 and then Ekind (Enclosing_Subprogram (T)) = E_Procedure; 7742 else 7743 Result := Is_Controlled (T); 7744 end if; 7745 7746 return Result; 7747 end; 7748 end; 7749 end if; 7750 end Is_Build_In_Place_Result_Type; 7751 7752 -------------------------------- 7753 -- Is_Build_In_Place_Function -- 7754 -------------------------------- 7755 7756 function Is_Build_In_Place_Function (E : Entity_Id) return Boolean is 7757 begin 7758 -- This function is called from Expand_Subtype_From_Expr during 7759 -- semantic analysis, even when expansion is off. In those cases 7760 -- the build_in_place expansion will not take place. 7761 7762 if not Expander_Active then 7763 return False; 7764 end if; 7765 7766 -- For now we test whether E denotes a function or access-to-function 7767 -- type whose result subtype is inherently limited. Later this test 7768 -- may be revised to allow composite nonlimited types. Functions with 7769 -- a foreign convention or whose result type has a foreign convention 7770 -- never qualify. 7771 7772 if Ekind_In (E, E_Function, E_Generic_Function) 7773 or else (Ekind (E) = E_Subprogram_Type 7774 and then Etype (E) /= Standard_Void_Type) 7775 then 7776 -- Note: If the function has a foreign convention, it cannot build 7777 -- its result in place, so you're on your own. On the other hand, 7778 -- if only the return type has a foreign convention, its layout is 7779 -- intended to be compatible with the other language, but the build- 7780 -- in place machinery can ensure that the object is not copied. 7781 7782 return Is_Build_In_Place_Result_Type (Etype (E)) 7783 and then not Has_Foreign_Convention (E) 7784 and then not Debug_Flag_Dot_L; 7785 else 7786 return False; 7787 end if; 7788 end Is_Build_In_Place_Function; 7789 7790 ------------------------------------- 7791 -- Is_Build_In_Place_Function_Call -- 7792 ------------------------------------- 7793 7794 function Is_Build_In_Place_Function_Call (N : Node_Id) return Boolean is 7795 Exp_Node : constant Node_Id := Unqual_Conv (N); 7796 Function_Id : Entity_Id; 7797 7798 begin 7799 -- Return False if the expander is currently inactive, since awareness 7800 -- of build-in-place treatment is only relevant during expansion. Note 7801 -- that Is_Build_In_Place_Function, which is called as part of this 7802 -- function, is also conditioned this way, but we need to check here as 7803 -- well to avoid blowing up on processing protected calls when expansion 7804 -- is disabled (such as with -gnatc) since those would trip over the 7805 -- raise of Program_Error below. 7806 7807 -- In SPARK mode, build-in-place calls are not expanded, so that we 7808 -- may end up with a call that is neither resolved to an entity, nor 7809 -- an indirect call. 7810 7811 if not Expander_Active or else Nkind (Exp_Node) /= N_Function_Call then 7812 return False; 7813 end if; 7814 7815 if Is_Entity_Name (Name (Exp_Node)) then 7816 Function_Id := Entity (Name (Exp_Node)); 7817 7818 -- In the case of an explicitly dereferenced call, use the subprogram 7819 -- type generated for the dereference. 7820 7821 elsif Nkind (Name (Exp_Node)) = N_Explicit_Dereference then 7822 Function_Id := Etype (Name (Exp_Node)); 7823 7824 -- This may be a call to a protected function. 7825 7826 elsif Nkind (Name (Exp_Node)) = N_Selected_Component then 7827 Function_Id := Etype (Entity (Selector_Name (Name (Exp_Node)))); 7828 7829 else 7830 raise Program_Error; 7831 end if; 7832 7833 declare 7834 Result : constant Boolean := Is_Build_In_Place_Function (Function_Id); 7835 -- So we can stop here in the debugger 7836 begin 7837 return Result; 7838 end; 7839 end Is_Build_In_Place_Function_Call; 7840 7841 ----------------------- 7842 -- Is_Null_Procedure -- 7843 ----------------------- 7844 7845 function Is_Null_Procedure (Subp : Entity_Id) return Boolean is 7846 Decl : constant Node_Id := Unit_Declaration_Node (Subp); 7847 7848 begin 7849 if Ekind (Subp) /= E_Procedure then 7850 return False; 7851 7852 -- Check if this is a declared null procedure 7853 7854 elsif Nkind (Decl) = N_Subprogram_Declaration then 7855 if not Null_Present (Specification (Decl)) then 7856 return False; 7857 7858 elsif No (Body_To_Inline (Decl)) then 7859 return False; 7860 7861 -- Check if the body contains only a null statement, followed by 7862 -- the return statement added during expansion. 7863 7864 else 7865 declare 7866 Orig_Bod : constant Node_Id := Body_To_Inline (Decl); 7867 7868 Stat : Node_Id; 7869 Stat2 : Node_Id; 7870 7871 begin 7872 if Nkind (Orig_Bod) /= N_Subprogram_Body then 7873 return False; 7874 else 7875 -- We must skip SCIL nodes because they are currently 7876 -- implemented as special N_Null_Statement nodes. 7877 7878 Stat := 7879 First_Non_SCIL_Node 7880 (Statements (Handled_Statement_Sequence (Orig_Bod))); 7881 Stat2 := Next_Non_SCIL_Node (Stat); 7882 7883 return 7884 Is_Empty_List (Declarations (Orig_Bod)) 7885 and then Nkind (Stat) = N_Null_Statement 7886 and then 7887 (No (Stat2) 7888 or else 7889 (Nkind (Stat2) = N_Simple_Return_Statement 7890 and then No (Next (Stat2)))); 7891 end if; 7892 end; 7893 end if; 7894 7895 else 7896 return False; 7897 end if; 7898 end Is_Null_Procedure; 7899 7900 ------------------------------------------- 7901 -- Make_Build_In_Place_Call_In_Allocator -- 7902 ------------------------------------------- 7903 7904 procedure Make_Build_In_Place_Call_In_Allocator 7905 (Allocator : Node_Id; 7906 Function_Call : Node_Id) 7907 is 7908 Acc_Type : constant Entity_Id := Etype (Allocator); 7909 Loc : constant Source_Ptr := Sloc (Function_Call); 7910 Func_Call : Node_Id := Function_Call; 7911 Ref_Func_Call : Node_Id; 7912 Function_Id : Entity_Id; 7913 Result_Subt : Entity_Id; 7914 New_Allocator : Node_Id; 7915 Return_Obj_Access : Entity_Id; -- temp for function result 7916 Temp_Init : Node_Id; -- initial value of Return_Obj_Access 7917 Alloc_Form : BIP_Allocation_Form; 7918 Pool : Node_Id; -- nonnull if Alloc_Form = User_Storage_Pool 7919 Return_Obj_Actual : Node_Id; -- the temp.all, in caller-allocates case 7920 Chain : Entity_Id; -- activation chain, in case of tasks 7921 7922 begin 7923 -- Step past qualification or unchecked conversion (the latter can occur 7924 -- in cases of calls to 'Input). 7925 7926 if Nkind_In (Func_Call, N_Qualified_Expression, 7927 N_Type_Conversion, 7928 N_Unchecked_Type_Conversion) 7929 then 7930 Func_Call := Expression (Func_Call); 7931 end if; 7932 7933 -- Mark the call as processed as a build-in-place call 7934 7935 pragma Assert (not Is_Expanded_Build_In_Place_Call (Func_Call)); 7936 Set_Is_Expanded_Build_In_Place_Call (Func_Call); 7937 7938 if Is_Entity_Name (Name (Func_Call)) then 7939 Function_Id := Entity (Name (Func_Call)); 7940 7941 elsif Nkind (Name (Func_Call)) = N_Explicit_Dereference then 7942 Function_Id := Etype (Name (Func_Call)); 7943 7944 else 7945 raise Program_Error; 7946 end if; 7947 7948 Result_Subt := Available_View (Etype (Function_Id)); 7949 7950 -- Create a temp for the function result. In the caller-allocates case, 7951 -- this will be initialized to the result of a new uninitialized 7952 -- allocator. Note: we do not use Allocator as the Related_Node of 7953 -- Return_Obj_Access in call to Make_Temporary below as this would 7954 -- create a sort of infinite "recursion". 7955 7956 Return_Obj_Access := Make_Temporary (Loc, 'R'); 7957 Set_Etype (Return_Obj_Access, Acc_Type); 7958 Set_Can_Never_Be_Null (Acc_Type, False); 7959 -- It gets initialized to null, so we can't have that 7960 7961 -- When the result subtype is constrained, the return object is created 7962 -- on the caller side, and access to it is passed to the function. This 7963 -- optimization is disabled when the result subtype needs finalization 7964 -- actions because the caller side allocation may result in undesirable 7965 -- finalization. Consider the following example: 7966 -- 7967 -- function Make_Lim_Ctrl return Lim_Ctrl is 7968 -- begin 7969 -- return Result : Lim_Ctrl := raise Program_Error do 7970 -- null; 7971 -- end return; 7972 -- end Make_Lim_Ctrl; 7973 -- 7974 -- Obj : Lim_Ctrl_Ptr := new Lim_Ctrl'(Make_Lim_Ctrl); 7975 -- 7976 -- Even though the size of limited controlled type Lim_Ctrl is known, 7977 -- allocating Obj at the caller side will chain Obj on Lim_Ctrl_Ptr's 7978 -- finalization master. The subsequent call to Make_Lim_Ctrl will fail 7979 -- during the initialization actions for Result, which implies that 7980 -- Result (and Obj by extension) should not be finalized. However Obj 7981 -- will be finalized when access type Lim_Ctrl_Ptr goes out of scope 7982 -- since it is already attached on the related finalization master. 7983 7984 -- Here and in related routines, we must examine the full view of the 7985 -- type, because the view at the point of call may differ from that 7986 -- that in the function body, and the expansion mechanism depends on 7987 -- the characteristics of the full view. 7988 7989 if Is_Constrained (Underlying_Type (Result_Subt)) 7990 and then not Needs_Finalization (Underlying_Type (Result_Subt)) 7991 then 7992 -- Replace the initialized allocator of form "new T'(Func (...))" 7993 -- with an uninitialized allocator of form "new T", where T is the 7994 -- result subtype of the called function. The call to the function 7995 -- is handled separately further below. 7996 7997 New_Allocator := 7998 Make_Allocator (Loc, 7999 Expression => New_Occurrence_Of (Result_Subt, Loc)); 8000 Set_No_Initialization (New_Allocator); 8001 8002 -- Copy attributes to new allocator. Note that the new allocator 8003 -- logically comes from source if the original one did, so copy the 8004 -- relevant flag. This ensures proper treatment of the restriction 8005 -- No_Implicit_Heap_Allocations in this case. 8006 8007 Set_Storage_Pool (New_Allocator, Storage_Pool (Allocator)); 8008 Set_Procedure_To_Call (New_Allocator, Procedure_To_Call (Allocator)); 8009 Set_Comes_From_Source (New_Allocator, Comes_From_Source (Allocator)); 8010 8011 Rewrite (Allocator, New_Allocator); 8012 8013 -- Initial value of the temp is the result of the uninitialized 8014 -- allocator. Unchecked_Convert is needed for T'Input where T is 8015 -- derived from a controlled type. 8016 8017 Temp_Init := Relocate_Node (Allocator); 8018 8019 if Nkind_In (Function_Call, N_Type_Conversion, 8020 N_Unchecked_Type_Conversion) 8021 then 8022 Temp_Init := Unchecked_Convert_To (Acc_Type, Temp_Init); 8023 end if; 8024 8025 -- Indicate that caller allocates, and pass in the return object 8026 8027 Alloc_Form := Caller_Allocation; 8028 Pool := Make_Null (No_Location); 8029 Return_Obj_Actual := 8030 Make_Unchecked_Type_Conversion (Loc, 8031 Subtype_Mark => New_Occurrence_Of (Result_Subt, Loc), 8032 Expression => 8033 Make_Explicit_Dereference (Loc, 8034 Prefix => New_Occurrence_Of (Return_Obj_Access, Loc))); 8035 8036 -- When the result subtype is unconstrained, the function itself must 8037 -- perform the allocation of the return object, so we pass parameters 8038 -- indicating that. 8039 8040 else 8041 Temp_Init := Empty; 8042 8043 -- Case of a user-defined storage pool. Pass an allocation parameter 8044 -- indicating that the function should allocate its result in the 8045 -- pool, and pass the pool. Use 'Unrestricted_Access because the 8046 -- pool may not be aliased. 8047 8048 if Present (Associated_Storage_Pool (Acc_Type)) then 8049 Alloc_Form := User_Storage_Pool; 8050 Pool := 8051 Make_Attribute_Reference (Loc, 8052 Prefix => 8053 New_Occurrence_Of 8054 (Associated_Storage_Pool (Acc_Type), Loc), 8055 Attribute_Name => Name_Unrestricted_Access); 8056 8057 -- No user-defined pool; pass an allocation parameter indicating that 8058 -- the function should allocate its result on the heap. 8059 8060 else 8061 Alloc_Form := Global_Heap; 8062 Pool := Make_Null (No_Location); 8063 end if; 8064 8065 -- The caller does not provide the return object in this case, so we 8066 -- have to pass null for the object access actual. 8067 8068 Return_Obj_Actual := Empty; 8069 end if; 8070 8071 -- Declare the temp object 8072 8073 Insert_Action (Allocator, 8074 Make_Object_Declaration (Loc, 8075 Defining_Identifier => Return_Obj_Access, 8076 Object_Definition => New_Occurrence_Of (Acc_Type, Loc), 8077 Expression => Temp_Init)); 8078 8079 Ref_Func_Call := Make_Reference (Loc, Func_Call); 8080 8081 -- Ada 2005 (AI-251): If the type of the allocator is an interface 8082 -- then generate an implicit conversion to force displacement of the 8083 -- "this" pointer. 8084 8085 if Is_Interface (Designated_Type (Acc_Type)) then 8086 Rewrite 8087 (Ref_Func_Call, 8088 OK_Convert_To (Acc_Type, Ref_Func_Call)); 8089 8090 -- If the types are incompatible, we need an unchecked conversion. Note 8091 -- that the full types will be compatible, but the types not visibly 8092 -- compatible. 8093 8094 elsif Nkind_In (Function_Call, N_Type_Conversion, 8095 N_Unchecked_Type_Conversion) 8096 then 8097 Ref_Func_Call := Unchecked_Convert_To (Acc_Type, Ref_Func_Call); 8098 end if; 8099 8100 declare 8101 Assign : constant Node_Id := 8102 Make_Assignment_Statement (Loc, 8103 Name => New_Occurrence_Of (Return_Obj_Access, Loc), 8104 Expression => Ref_Func_Call); 8105 -- Assign the result of the function call into the temp. In the 8106 -- caller-allocates case, this is overwriting the temp with its 8107 -- initial value, which has no effect. In the callee-allocates case, 8108 -- this is setting the temp to point to the object allocated by the 8109 -- callee. Unchecked_Convert is needed for T'Input where T is derived 8110 -- from a controlled type. 8111 8112 Actions : List_Id; 8113 -- Actions to be inserted. If there are no tasks, this is just the 8114 -- assignment statement. If the allocated object has tasks, we need 8115 -- to wrap the assignment in a block that activates them. The 8116 -- activation chain of that block must be passed to the function, 8117 -- rather than some outer chain. 8118 8119 begin 8120 if Has_Task (Result_Subt) then 8121 Actions := New_List; 8122 Build_Task_Allocate_Block_With_Init_Stmts 8123 (Actions, Allocator, Init_Stmts => New_List (Assign)); 8124 Chain := Activation_Chain_Entity (Last (Actions)); 8125 else 8126 Actions := New_List (Assign); 8127 Chain := Empty; 8128 end if; 8129 8130 Insert_Actions (Allocator, Actions); 8131 end; 8132 8133 -- When the function has a controlling result, an allocation-form 8134 -- parameter must be passed indicating that the caller is allocating 8135 -- the result object. This is needed because such a function can be 8136 -- called as a dispatching operation and must be treated similarly 8137 -- to functions with unconstrained result subtypes. 8138 8139 Add_Unconstrained_Actuals_To_Build_In_Place_Call 8140 (Func_Call, Function_Id, Alloc_Form, Pool_Actual => Pool); 8141 8142 Add_Finalization_Master_Actual_To_Build_In_Place_Call 8143 (Func_Call, Function_Id, Acc_Type); 8144 8145 Add_Task_Actuals_To_Build_In_Place_Call 8146 (Func_Call, Function_Id, Master_Actual => Master_Id (Acc_Type), 8147 Chain => Chain); 8148 8149 -- Add an implicit actual to the function call that provides access 8150 -- to the allocated object. An unchecked conversion to the (specific) 8151 -- result subtype of the function is inserted to handle cases where 8152 -- the access type of the allocator has a class-wide designated type. 8153 8154 Add_Access_Actual_To_Build_In_Place_Call 8155 (Func_Call, Function_Id, Return_Obj_Actual); 8156 8157 -- Finally, replace the allocator node with a reference to the temp 8158 8159 Rewrite (Allocator, New_Occurrence_Of (Return_Obj_Access, Loc)); 8160 8161 Analyze_And_Resolve (Allocator, Acc_Type); 8162 end Make_Build_In_Place_Call_In_Allocator; 8163 8164 --------------------------------------------------- 8165 -- Make_Build_In_Place_Call_In_Anonymous_Context -- 8166 --------------------------------------------------- 8167 8168 procedure Make_Build_In_Place_Call_In_Anonymous_Context 8169 (Function_Call : Node_Id) 8170 is 8171 Loc : constant Source_Ptr := Sloc (Function_Call); 8172 Func_Call : constant Node_Id := Unqual_Conv (Function_Call); 8173 Function_Id : Entity_Id; 8174 Result_Subt : Entity_Id; 8175 Return_Obj_Id : Entity_Id; 8176 Return_Obj_Decl : Entity_Id; 8177 8178 begin 8179 -- If the call has already been processed to add build-in-place actuals 8180 -- then return. One place this can occur is for calls to build-in-place 8181 -- functions that occur within a call to a protected operation, where 8182 -- due to rewriting and expansion of the protected call there can be 8183 -- more than one call to Expand_Actuals for the same set of actuals. 8184 8185 if Is_Expanded_Build_In_Place_Call (Func_Call) then 8186 return; 8187 end if; 8188 8189 -- Mark the call as processed as a build-in-place call 8190 8191 Set_Is_Expanded_Build_In_Place_Call (Func_Call); 8192 8193 if Is_Entity_Name (Name (Func_Call)) then 8194 Function_Id := Entity (Name (Func_Call)); 8195 8196 elsif Nkind (Name (Func_Call)) = N_Explicit_Dereference then 8197 Function_Id := Etype (Name (Func_Call)); 8198 8199 else 8200 raise Program_Error; 8201 end if; 8202 8203 Result_Subt := Etype (Function_Id); 8204 8205 -- If the build-in-place function returns a controlled object, then the 8206 -- object needs to be finalized immediately after the context. Since 8207 -- this case produces a transient scope, the servicing finalizer needs 8208 -- to name the returned object. Create a temporary which is initialized 8209 -- with the function call: 8210 -- 8211 -- Temp_Id : Func_Type := BIP_Func_Call; 8212 -- 8213 -- The initialization expression of the temporary will be rewritten by 8214 -- the expander using the appropriate mechanism in Make_Build_In_Place_ 8215 -- Call_In_Object_Declaration. 8216 8217 if Needs_Finalization (Result_Subt) then 8218 declare 8219 Temp_Id : constant Entity_Id := Make_Temporary (Loc, 'R'); 8220 Temp_Decl : Node_Id; 8221 8222 begin 8223 -- Reset the guard on the function call since the following does 8224 -- not perform actual call expansion. 8225 8226 Set_Is_Expanded_Build_In_Place_Call (Func_Call, False); 8227 8228 Temp_Decl := 8229 Make_Object_Declaration (Loc, 8230 Defining_Identifier => Temp_Id, 8231 Object_Definition => 8232 New_Occurrence_Of (Result_Subt, Loc), 8233 Expression => 8234 New_Copy_Tree (Function_Call)); 8235 8236 Insert_Action (Function_Call, Temp_Decl); 8237 8238 Rewrite (Function_Call, New_Occurrence_Of (Temp_Id, Loc)); 8239 Analyze (Function_Call); 8240 end; 8241 8242 -- When the result subtype is definite, an object of the subtype is 8243 -- declared and an access value designating it is passed as an actual. 8244 8245 elsif Caller_Known_Size (Func_Call, Result_Subt) then 8246 8247 -- Create a temporary object to hold the function result 8248 8249 Return_Obj_Id := Make_Temporary (Loc, 'R'); 8250 Set_Etype (Return_Obj_Id, Result_Subt); 8251 8252 Return_Obj_Decl := 8253 Make_Object_Declaration (Loc, 8254 Defining_Identifier => Return_Obj_Id, 8255 Aliased_Present => True, 8256 Object_Definition => New_Occurrence_Of (Result_Subt, Loc)); 8257 8258 Set_No_Initialization (Return_Obj_Decl); 8259 8260 Insert_Action (Func_Call, Return_Obj_Decl); 8261 8262 -- When the function has a controlling result, an allocation-form 8263 -- parameter must be passed indicating that the caller is allocating 8264 -- the result object. This is needed because such a function can be 8265 -- called as a dispatching operation and must be treated similarly 8266 -- to functions with unconstrained result subtypes. 8267 8268 Add_Unconstrained_Actuals_To_Build_In_Place_Call 8269 (Func_Call, Function_Id, Alloc_Form => Caller_Allocation); 8270 8271 Add_Finalization_Master_Actual_To_Build_In_Place_Call 8272 (Func_Call, Function_Id); 8273 8274 Add_Task_Actuals_To_Build_In_Place_Call 8275 (Func_Call, Function_Id, Make_Identifier (Loc, Name_uMaster)); 8276 8277 -- Add an implicit actual to the function call that provides access 8278 -- to the caller's return object. 8279 8280 Add_Access_Actual_To_Build_In_Place_Call 8281 (Func_Call, Function_Id, New_Occurrence_Of (Return_Obj_Id, Loc)); 8282 8283 -- When the result subtype is unconstrained, the function must allocate 8284 -- the return object in the secondary stack, so appropriate implicit 8285 -- parameters are added to the call to indicate that. A transient 8286 -- scope is established to ensure eventual cleanup of the result. 8287 8288 else 8289 -- Pass an allocation parameter indicating that the function should 8290 -- allocate its result on the secondary stack. 8291 8292 Add_Unconstrained_Actuals_To_Build_In_Place_Call 8293 (Func_Call, Function_Id, Alloc_Form => Secondary_Stack); 8294 8295 Add_Finalization_Master_Actual_To_Build_In_Place_Call 8296 (Func_Call, Function_Id); 8297 8298 Add_Task_Actuals_To_Build_In_Place_Call 8299 (Func_Call, Function_Id, Make_Identifier (Loc, Name_uMaster)); 8300 8301 -- Pass a null value to the function since no return object is 8302 -- available on the caller side. 8303 8304 Add_Access_Actual_To_Build_In_Place_Call 8305 (Func_Call, Function_Id, Empty); 8306 end if; 8307 end Make_Build_In_Place_Call_In_Anonymous_Context; 8308 8309 -------------------------------------------- 8310 -- Make_Build_In_Place_Call_In_Assignment -- 8311 -------------------------------------------- 8312 8313 procedure Make_Build_In_Place_Call_In_Assignment 8314 (Assign : Node_Id; 8315 Function_Call : Node_Id) 8316 is 8317 Func_Call : constant Node_Id := Unqual_Conv (Function_Call); 8318 Lhs : constant Node_Id := Name (Assign); 8319 Loc : constant Source_Ptr := Sloc (Function_Call); 8320 Func_Id : Entity_Id; 8321 Obj_Decl : Node_Id; 8322 Obj_Id : Entity_Id; 8323 Ptr_Typ : Entity_Id; 8324 Ptr_Typ_Decl : Node_Id; 8325 New_Expr : Node_Id; 8326 Result_Subt : Entity_Id; 8327 8328 begin 8329 -- Mark the call as processed as a build-in-place call 8330 8331 pragma Assert (not Is_Expanded_Build_In_Place_Call (Func_Call)); 8332 Set_Is_Expanded_Build_In_Place_Call (Func_Call); 8333 8334 if Is_Entity_Name (Name (Func_Call)) then 8335 Func_Id := Entity (Name (Func_Call)); 8336 8337 elsif Nkind (Name (Func_Call)) = N_Explicit_Dereference then 8338 Func_Id := Etype (Name (Func_Call)); 8339 8340 else 8341 raise Program_Error; 8342 end if; 8343 8344 Result_Subt := Etype (Func_Id); 8345 8346 -- When the result subtype is unconstrained, an additional actual must 8347 -- be passed to indicate that the caller is providing the return object. 8348 -- This parameter must also be passed when the called function has a 8349 -- controlling result, because dispatching calls to the function needs 8350 -- to be treated effectively the same as calls to class-wide functions. 8351 8352 Add_Unconstrained_Actuals_To_Build_In_Place_Call 8353 (Func_Call, Func_Id, Alloc_Form => Caller_Allocation); 8354 8355 Add_Finalization_Master_Actual_To_Build_In_Place_Call 8356 (Func_Call, Func_Id); 8357 8358 Add_Task_Actuals_To_Build_In_Place_Call 8359 (Func_Call, Func_Id, Make_Identifier (Loc, Name_uMaster)); 8360 8361 -- Add an implicit actual to the function call that provides access to 8362 -- the caller's return object. 8363 8364 Add_Access_Actual_To_Build_In_Place_Call 8365 (Func_Call, 8366 Func_Id, 8367 Make_Unchecked_Type_Conversion (Loc, 8368 Subtype_Mark => New_Occurrence_Of (Result_Subt, Loc), 8369 Expression => Relocate_Node (Lhs))); 8370 8371 -- Create an access type designating the function's result subtype 8372 8373 Ptr_Typ := Make_Temporary (Loc, 'A'); 8374 8375 Ptr_Typ_Decl := 8376 Make_Full_Type_Declaration (Loc, 8377 Defining_Identifier => Ptr_Typ, 8378 Type_Definition => 8379 Make_Access_To_Object_Definition (Loc, 8380 All_Present => True, 8381 Subtype_Indication => 8382 New_Occurrence_Of (Result_Subt, Loc))); 8383 Insert_After_And_Analyze (Assign, Ptr_Typ_Decl); 8384 8385 -- Finally, create an access object initialized to a reference to the 8386 -- function call. We know this access value is non-null, so mark the 8387 -- entity accordingly to suppress junk access checks. 8388 8389 New_Expr := Make_Reference (Loc, Relocate_Node (Func_Call)); 8390 8391 -- Add a conversion if it's the wrong type 8392 8393 if Etype (New_Expr) /= Ptr_Typ then 8394 New_Expr := 8395 Make_Unchecked_Type_Conversion (Loc, 8396 New_Occurrence_Of (Ptr_Typ, Loc), New_Expr); 8397 end if; 8398 8399 Obj_Id := Make_Temporary (Loc, 'R', New_Expr); 8400 Set_Etype (Obj_Id, Ptr_Typ); 8401 Set_Is_Known_Non_Null (Obj_Id); 8402 8403 Obj_Decl := 8404 Make_Object_Declaration (Loc, 8405 Defining_Identifier => Obj_Id, 8406 Object_Definition => New_Occurrence_Of (Ptr_Typ, Loc), 8407 Expression => New_Expr); 8408 Insert_After_And_Analyze (Ptr_Typ_Decl, Obj_Decl); 8409 8410 Rewrite (Assign, Make_Null_Statement (Loc)); 8411 end Make_Build_In_Place_Call_In_Assignment; 8412 8413 ---------------------------------------------------- 8414 -- Make_Build_In_Place_Call_In_Object_Declaration -- 8415 ---------------------------------------------------- 8416 8417 procedure Make_Build_In_Place_Call_In_Object_Declaration 8418 (Obj_Decl : Node_Id; 8419 Function_Call : Node_Id) 8420 is 8421 function Get_Function_Id (Func_Call : Node_Id) return Entity_Id; 8422 -- Get the value of Function_Id, below 8423 8424 --------------------- 8425 -- Get_Function_Id -- 8426 --------------------- 8427 8428 function Get_Function_Id (Func_Call : Node_Id) return Entity_Id is 8429 begin 8430 if Is_Entity_Name (Name (Func_Call)) then 8431 return Entity (Name (Func_Call)); 8432 8433 elsif Nkind (Name (Func_Call)) = N_Explicit_Dereference then 8434 return Etype (Name (Func_Call)); 8435 8436 else 8437 raise Program_Error; 8438 end if; 8439 end Get_Function_Id; 8440 8441 -- Local variables 8442 8443 Func_Call : constant Node_Id := Unqual_Conv (Function_Call); 8444 Function_Id : constant Entity_Id := Get_Function_Id (Func_Call); 8445 Loc : constant Source_Ptr := Sloc (Function_Call); 8446 Obj_Loc : constant Source_Ptr := Sloc (Obj_Decl); 8447 Obj_Def_Id : constant Entity_Id := Defining_Identifier (Obj_Decl); 8448 Obj_Typ : constant Entity_Id := Etype (Obj_Def_Id); 8449 Encl_Func : constant Entity_Id := Enclosing_Subprogram (Obj_Def_Id); 8450 Result_Subt : constant Entity_Id := Etype (Function_Id); 8451 8452 Call_Deref : Node_Id; 8453 Caller_Object : Node_Id; 8454 Def_Id : Entity_Id; 8455 Designated_Type : Entity_Id; 8456 Fmaster_Actual : Node_Id := Empty; 8457 Pool_Actual : Node_Id; 8458 Ptr_Typ : Entity_Id; 8459 Ptr_Typ_Decl : Node_Id; 8460 Pass_Caller_Acc : Boolean := False; 8461 Res_Decl : Node_Id; 8462 8463 Definite : constant Boolean := 8464 Caller_Known_Size (Func_Call, Result_Subt) 8465 and then not Is_Class_Wide_Type (Obj_Typ); 8466 -- In the case of "X : T'Class := F(...);", where F returns a 8467 -- Caller_Known_Size (specific) tagged type, we treat it as 8468 -- indefinite, because the code for the Definite case below sets the 8469 -- initialization expression of the object to Empty, which would be 8470 -- illegal Ada, and would cause gigi to misallocate X. 8471 8472 -- Start of processing for Make_Build_In_Place_Call_In_Object_Declaration 8473 8474 begin 8475 -- If the call has already been processed to add build-in-place actuals 8476 -- then return. 8477 8478 if Is_Expanded_Build_In_Place_Call (Func_Call) then 8479 return; 8480 end if; 8481 8482 -- Mark the call as processed as a build-in-place call 8483 8484 Set_Is_Expanded_Build_In_Place_Call (Func_Call); 8485 8486 -- Create an access type designating the function's result subtype. 8487 -- We use the type of the original call because it may be a call to an 8488 -- inherited operation, which the expansion has replaced with the parent 8489 -- operation that yields the parent type. Note that this access type 8490 -- must be declared before we establish a transient scope, so that it 8491 -- receives the proper accessibility level. 8492 8493 if Is_Class_Wide_Type (Obj_Typ) 8494 and then not Is_Interface (Obj_Typ) 8495 and then not Is_Class_Wide_Type (Etype (Function_Call)) 8496 then 8497 Designated_Type := Obj_Typ; 8498 else 8499 Designated_Type := Etype (Function_Call); 8500 end if; 8501 8502 Ptr_Typ := Make_Temporary (Loc, 'A'); 8503 Ptr_Typ_Decl := 8504 Make_Full_Type_Declaration (Loc, 8505 Defining_Identifier => Ptr_Typ, 8506 Type_Definition => 8507 Make_Access_To_Object_Definition (Loc, 8508 All_Present => True, 8509 Subtype_Indication => 8510 New_Occurrence_Of (Designated_Type, Loc))); 8511 8512 -- The access type and its accompanying object must be inserted after 8513 -- the object declaration in the constrained case, so that the function 8514 -- call can be passed access to the object. In the indefinite case, or 8515 -- if the object declaration is for a return object, the access type and 8516 -- object must be inserted before the object, since the object 8517 -- declaration is rewritten to be a renaming of a dereference of the 8518 -- access object. Note: we need to freeze Ptr_Typ explicitly, because 8519 -- the result object is in a different (transient) scope, so won't cause 8520 -- freezing. 8521 8522 if Definite and then not Is_Return_Object (Obj_Def_Id) then 8523 8524 -- The presence of an address clause complicates the build-in-place 8525 -- expansion because the indicated address must be processed before 8526 -- the indirect call is generated (including the definition of a 8527 -- local pointer to the object). The address clause may come from 8528 -- an aspect specification or from an explicit attribute 8529 -- specification appearing after the object declaration. These two 8530 -- cases require different processing. 8531 8532 if Has_Aspect (Obj_Def_Id, Aspect_Address) then 8533 8534 -- Skip non-delayed pragmas that correspond to other aspects, if 8535 -- any, to find proper insertion point for freeze node of object. 8536 8537 declare 8538 D : Node_Id := Obj_Decl; 8539 N : Node_Id := Next (D); 8540 8541 begin 8542 while Present (N) 8543 and then Nkind_In (N, N_Attribute_Reference, N_Pragma) 8544 loop 8545 Analyze (N); 8546 D := N; 8547 Next (N); 8548 end loop; 8549 8550 Insert_After (D, Ptr_Typ_Decl); 8551 8552 -- Freeze object before pointer declaration, to ensure that 8553 -- generated attribute for address is inserted at the proper 8554 -- place. 8555 8556 Freeze_Before (Ptr_Typ_Decl, Obj_Def_Id); 8557 end; 8558 8559 Analyze (Ptr_Typ_Decl); 8560 8561 elsif Present (Following_Address_Clause (Obj_Decl)) then 8562 8563 -- Locate explicit address clause, which may also follow pragmas 8564 -- generated by other aspect specifications. 8565 8566 declare 8567 Addr : constant Node_Id := Following_Address_Clause (Obj_Decl); 8568 D : Node_Id := Next (Obj_Decl); 8569 8570 begin 8571 while Present (D) loop 8572 Analyze (D); 8573 exit when D = Addr; 8574 Next (D); 8575 end loop; 8576 8577 Insert_After_And_Analyze (Addr, Ptr_Typ_Decl); 8578 end; 8579 8580 else 8581 Insert_After_And_Analyze (Obj_Decl, Ptr_Typ_Decl); 8582 end if; 8583 else 8584 Insert_Action (Obj_Decl, Ptr_Typ_Decl); 8585 end if; 8586 8587 -- Force immediate freezing of Ptr_Typ because Res_Decl will be 8588 -- elaborated in an inner (transient) scope and thus won't cause 8589 -- freezing by itself. It's not an itype, but it needs to be frozen 8590 -- inside the current subprogram (see Freeze_Outside in freeze.adb). 8591 8592 Freeze_Itype (Ptr_Typ, Ptr_Typ_Decl); 8593 8594 -- If the object is a return object of an enclosing build-in-place 8595 -- function, then the implicit build-in-place parameters of the 8596 -- enclosing function are simply passed along to the called function. 8597 -- (Unfortunately, this won't cover the case of extension aggregates 8598 -- where the ancestor part is a build-in-place indefinite function 8599 -- call that should be passed along the caller's parameters. 8600 -- Currently those get mishandled by reassigning the result of the 8601 -- call to the aggregate return object, when the call result should 8602 -- really be directly built in place in the aggregate and not in a 8603 -- temporary. ???) 8604 8605 if Is_Return_Object (Obj_Def_Id) then 8606 Pass_Caller_Acc := True; 8607 8608 -- When the enclosing function has a BIP_Alloc_Form formal then we 8609 -- pass it along to the callee (such as when the enclosing function 8610 -- has an unconstrained or tagged result type). 8611 8612 if Needs_BIP_Alloc_Form (Encl_Func) then 8613 if RTE_Available (RE_Root_Storage_Pool_Ptr) then 8614 Pool_Actual := 8615 New_Occurrence_Of 8616 (Build_In_Place_Formal 8617 (Encl_Func, BIP_Storage_Pool), Loc); 8618 8619 -- The build-in-place pool formal is not built on e.g. ZFP 8620 8621 else 8622 Pool_Actual := Empty; 8623 end if; 8624 8625 Add_Unconstrained_Actuals_To_Build_In_Place_Call 8626 (Function_Call => Func_Call, 8627 Function_Id => Function_Id, 8628 Alloc_Form_Exp => 8629 New_Occurrence_Of 8630 (Build_In_Place_Formal (Encl_Func, BIP_Alloc_Form), Loc), 8631 Pool_Actual => Pool_Actual); 8632 8633 -- Otherwise, if enclosing function has a definite result subtype, 8634 -- then caller allocation will be used. 8635 8636 else 8637 Add_Unconstrained_Actuals_To_Build_In_Place_Call 8638 (Func_Call, Function_Id, Alloc_Form => Caller_Allocation); 8639 end if; 8640 8641 if Needs_BIP_Finalization_Master (Encl_Func) then 8642 Fmaster_Actual := 8643 New_Occurrence_Of 8644 (Build_In_Place_Formal 8645 (Encl_Func, BIP_Finalization_Master), Loc); 8646 end if; 8647 8648 -- Retrieve the BIPacc formal from the enclosing function and convert 8649 -- it to the access type of the callee's BIP_Object_Access formal. 8650 8651 Caller_Object := 8652 Make_Unchecked_Type_Conversion (Loc, 8653 Subtype_Mark => 8654 New_Occurrence_Of 8655 (Etype (Build_In_Place_Formal 8656 (Function_Id, BIP_Object_Access)), 8657 Loc), 8658 Expression => 8659 New_Occurrence_Of 8660 (Build_In_Place_Formal (Encl_Func, BIP_Object_Access), 8661 Loc)); 8662 8663 -- In the definite case, add an implicit actual to the function call 8664 -- that provides access to the declared object. An unchecked conversion 8665 -- to the (specific) result type of the function is inserted to handle 8666 -- the case where the object is declared with a class-wide type. 8667 8668 elsif Definite then 8669 Caller_Object := 8670 Make_Unchecked_Type_Conversion (Loc, 8671 Subtype_Mark => New_Occurrence_Of (Result_Subt, Loc), 8672 Expression => New_Occurrence_Of (Obj_Def_Id, Loc)); 8673 8674 -- When the function has a controlling result, an allocation-form 8675 -- parameter must be passed indicating that the caller is allocating 8676 -- the result object. This is needed because such a function can be 8677 -- called as a dispatching operation and must be treated similarly to 8678 -- functions with indefinite result subtypes. 8679 8680 Add_Unconstrained_Actuals_To_Build_In_Place_Call 8681 (Func_Call, Function_Id, Alloc_Form => Caller_Allocation); 8682 8683 -- The allocation for indefinite library-level objects occurs on the 8684 -- heap as opposed to the secondary stack. This accommodates DLLs where 8685 -- the secondary stack is destroyed after each library unload. This is a 8686 -- hybrid mechanism where a stack-allocated object lives on the heap. 8687 8688 elsif Is_Library_Level_Entity (Obj_Def_Id) 8689 and then not Restriction_Active (No_Implicit_Heap_Allocations) 8690 then 8691 Add_Unconstrained_Actuals_To_Build_In_Place_Call 8692 (Func_Call, Function_Id, Alloc_Form => Global_Heap); 8693 Caller_Object := Empty; 8694 8695 -- Create a finalization master for the access result type to ensure 8696 -- that the heap allocation can properly chain the object and later 8697 -- finalize it when the library unit goes out of scope. 8698 8699 if Needs_Finalization (Etype (Func_Call)) then 8700 Build_Finalization_Master 8701 (Typ => Ptr_Typ, 8702 For_Lib_Level => True, 8703 Insertion_Node => Ptr_Typ_Decl); 8704 8705 Fmaster_Actual := 8706 Make_Attribute_Reference (Loc, 8707 Prefix => 8708 New_Occurrence_Of (Finalization_Master (Ptr_Typ), Loc), 8709 Attribute_Name => Name_Unrestricted_Access); 8710 end if; 8711 8712 -- In other indefinite cases, pass an indication to do the allocation 8713 -- on the secondary stack and set Caller_Object to Empty so that a null 8714 -- value will be passed for the caller's object address. A transient 8715 -- scope is established to ensure eventual cleanup of the result. 8716 8717 else 8718 Add_Unconstrained_Actuals_To_Build_In_Place_Call 8719 (Func_Call, Function_Id, Alloc_Form => Secondary_Stack); 8720 Caller_Object := Empty; 8721 8722 Establish_Transient_Scope (Obj_Decl, Manage_Sec_Stack => True); 8723 end if; 8724 8725 -- Pass along any finalization master actual, which is needed in the 8726 -- case where the called function initializes a return object of an 8727 -- enclosing build-in-place function. 8728 8729 Add_Finalization_Master_Actual_To_Build_In_Place_Call 8730 (Func_Call => Func_Call, 8731 Func_Id => Function_Id, 8732 Master_Exp => Fmaster_Actual); 8733 8734 if Nkind (Parent (Obj_Decl)) = N_Extended_Return_Statement 8735 and then Has_Task (Result_Subt) 8736 then 8737 -- Here we're passing along the master that was passed in to this 8738 -- function. 8739 8740 Add_Task_Actuals_To_Build_In_Place_Call 8741 (Func_Call, Function_Id, 8742 Master_Actual => 8743 New_Occurrence_Of 8744 (Build_In_Place_Formal (Encl_Func, BIP_Task_Master), Loc)); 8745 8746 else 8747 Add_Task_Actuals_To_Build_In_Place_Call 8748 (Func_Call, Function_Id, Make_Identifier (Loc, Name_uMaster)); 8749 end if; 8750 8751 Add_Access_Actual_To_Build_In_Place_Call 8752 (Func_Call, 8753 Function_Id, 8754 Caller_Object, 8755 Is_Access => Pass_Caller_Acc); 8756 8757 -- Finally, create an access object initialized to a reference to the 8758 -- function call. We know this access value cannot be null, so mark the 8759 -- entity accordingly to suppress the access check. 8760 8761 Def_Id := Make_Temporary (Loc, 'R', Func_Call); 8762 Set_Etype (Def_Id, Ptr_Typ); 8763 Set_Is_Known_Non_Null (Def_Id); 8764 8765 if Nkind_In (Function_Call, N_Type_Conversion, 8766 N_Unchecked_Type_Conversion) 8767 then 8768 Res_Decl := 8769 Make_Object_Declaration (Loc, 8770 Defining_Identifier => Def_Id, 8771 Constant_Present => True, 8772 Object_Definition => New_Occurrence_Of (Ptr_Typ, Loc), 8773 Expression => 8774 Make_Unchecked_Type_Conversion (Loc, 8775 New_Occurrence_Of (Ptr_Typ, Loc), 8776 Make_Reference (Loc, Relocate_Node (Func_Call)))); 8777 else 8778 Res_Decl := 8779 Make_Object_Declaration (Loc, 8780 Defining_Identifier => Def_Id, 8781 Constant_Present => True, 8782 Object_Definition => New_Occurrence_Of (Ptr_Typ, Loc), 8783 Expression => 8784 Make_Reference (Loc, Relocate_Node (Func_Call))); 8785 end if; 8786 8787 Insert_After_And_Analyze (Ptr_Typ_Decl, Res_Decl); 8788 8789 -- If the result subtype of the called function is definite and is not 8790 -- itself the return expression of an enclosing BIP function, then mark 8791 -- the object as having no initialization. 8792 8793 if Definite and then not Is_Return_Object (Obj_Def_Id) then 8794 8795 -- The related object declaration is encased in a transient block 8796 -- because the build-in-place function call contains at least one 8797 -- nested function call that produces a controlled transient 8798 -- temporary: 8799 8800 -- Obj : ... := BIP_Func_Call (Ctrl_Func_Call); 8801 8802 -- Since the build-in-place expansion decouples the call from the 8803 -- object declaration, the finalization machinery lacks the context 8804 -- which prompted the generation of the transient block. To resolve 8805 -- this scenario, store the build-in-place call. 8806 8807 if Scope_Is_Transient and then Node_To_Be_Wrapped = Obj_Decl then 8808 Set_BIP_Initialization_Call (Obj_Def_Id, Res_Decl); 8809 end if; 8810 8811 Set_Expression (Obj_Decl, Empty); 8812 Set_No_Initialization (Obj_Decl); 8813 8814 -- In case of an indefinite result subtype, or if the call is the 8815 -- return expression of an enclosing BIP function, rewrite the object 8816 -- declaration as an object renaming where the renamed object is a 8817 -- dereference of <function_Call>'reference: 8818 -- 8819 -- Obj : Subt renames <function_call>'Ref.all; 8820 8821 else 8822 Call_Deref := 8823 Make_Explicit_Dereference (Obj_Loc, 8824 Prefix => New_Occurrence_Of (Def_Id, Obj_Loc)); 8825 8826 Rewrite (Obj_Decl, 8827 Make_Object_Renaming_Declaration (Obj_Loc, 8828 Defining_Identifier => Make_Temporary (Obj_Loc, 'D'), 8829 Subtype_Mark => 8830 New_Occurrence_Of (Designated_Type, Obj_Loc), 8831 Name => Call_Deref)); 8832 8833 -- At this point, Defining_Identifier (Obj_Decl) is no longer equal 8834 -- to Obj_Def_Id. 8835 8836 Set_Renamed_Object (Defining_Identifier (Obj_Decl), Call_Deref); 8837 8838 -- If the original entity comes from source, then mark the new 8839 -- entity as needing debug information, even though it's defined 8840 -- by a generated renaming that does not come from source, so that 8841 -- the Materialize_Entity flag will be set on the entity when 8842 -- Debug_Renaming_Declaration is called during analysis. 8843 8844 if Comes_From_Source (Obj_Def_Id) then 8845 Set_Debug_Info_Needed (Defining_Identifier (Obj_Decl)); 8846 end if; 8847 8848 Analyze (Obj_Decl); 8849 Replace_Renaming_Declaration_Id 8850 (Obj_Decl, Original_Node (Obj_Decl)); 8851 end if; 8852 end Make_Build_In_Place_Call_In_Object_Declaration; 8853 8854 ------------------------------------------------- 8855 -- Make_Build_In_Place_Iface_Call_In_Allocator -- 8856 ------------------------------------------------- 8857 8858 procedure Make_Build_In_Place_Iface_Call_In_Allocator 8859 (Allocator : Node_Id; 8860 Function_Call : Node_Id) 8861 is 8862 BIP_Func_Call : constant Node_Id := 8863 Unqual_BIP_Iface_Function_Call (Function_Call); 8864 Loc : constant Source_Ptr := Sloc (Function_Call); 8865 8866 Anon_Type : Entity_Id; 8867 Tmp_Decl : Node_Id; 8868 Tmp_Id : Entity_Id; 8869 8870 begin 8871 -- No action of the call has already been processed 8872 8873 if Is_Expanded_Build_In_Place_Call (BIP_Func_Call) then 8874 return; 8875 end if; 8876 8877 Tmp_Id := Make_Temporary (Loc, 'D'); 8878 8879 -- Insert a temporary before N initialized with the BIP function call 8880 -- without its enclosing type conversions and analyze it without its 8881 -- expansion. This temporary facilitates us reusing the BIP machinery, 8882 -- which takes care of adding the extra build-in-place actuals and 8883 -- transforms this object declaration into an object renaming 8884 -- declaration. 8885 8886 Anon_Type := Create_Itype (E_Anonymous_Access_Type, Function_Call); 8887 Set_Directly_Designated_Type (Anon_Type, Etype (BIP_Func_Call)); 8888 Set_Etype (Anon_Type, Anon_Type); 8889 8890 Tmp_Decl := 8891 Make_Object_Declaration (Loc, 8892 Defining_Identifier => Tmp_Id, 8893 Object_Definition => New_Occurrence_Of (Anon_Type, Loc), 8894 Expression => 8895 Make_Allocator (Loc, 8896 Expression => 8897 Make_Qualified_Expression (Loc, 8898 Subtype_Mark => 8899 New_Occurrence_Of (Etype (BIP_Func_Call), Loc), 8900 Expression => New_Copy_Tree (BIP_Func_Call)))); 8901 8902 Expander_Mode_Save_And_Set (False); 8903 Insert_Action (Allocator, Tmp_Decl); 8904 Expander_Mode_Restore; 8905 8906 Make_Build_In_Place_Call_In_Allocator 8907 (Allocator => Expression (Tmp_Decl), 8908 Function_Call => Expression (Expression (Tmp_Decl))); 8909 8910 Rewrite (Allocator, New_Occurrence_Of (Tmp_Id, Loc)); 8911 end Make_Build_In_Place_Iface_Call_In_Allocator; 8912 8913 --------------------------------------------------------- 8914 -- Make_Build_In_Place_Iface_Call_In_Anonymous_Context -- 8915 --------------------------------------------------------- 8916 8917 procedure Make_Build_In_Place_Iface_Call_In_Anonymous_Context 8918 (Function_Call : Node_Id) 8919 is 8920 BIP_Func_Call : constant Node_Id := 8921 Unqual_BIP_Iface_Function_Call (Function_Call); 8922 Loc : constant Source_Ptr := Sloc (Function_Call); 8923 8924 Tmp_Decl : Node_Id; 8925 Tmp_Id : Entity_Id; 8926 8927 begin 8928 -- No action of the call has already been processed 8929 8930 if Is_Expanded_Build_In_Place_Call (BIP_Func_Call) then 8931 return; 8932 end if; 8933 8934 pragma Assert (Needs_Finalization (Etype (BIP_Func_Call))); 8935 8936 -- Insert a temporary before the call initialized with function call to 8937 -- reuse the BIP machinery which takes care of adding the extra build-in 8938 -- place actuals and transforms this object declaration into an object 8939 -- renaming declaration. 8940 8941 Tmp_Id := Make_Temporary (Loc, 'D'); 8942 8943 Tmp_Decl := 8944 Make_Object_Declaration (Loc, 8945 Defining_Identifier => Tmp_Id, 8946 Object_Definition => 8947 New_Occurrence_Of (Etype (Function_Call), Loc), 8948 Expression => Relocate_Node (Function_Call)); 8949 8950 Expander_Mode_Save_And_Set (False); 8951 Insert_Action (Function_Call, Tmp_Decl); 8952 Expander_Mode_Restore; 8953 8954 Make_Build_In_Place_Iface_Call_In_Object_Declaration 8955 (Obj_Decl => Tmp_Decl, 8956 Function_Call => Expression (Tmp_Decl)); 8957 end Make_Build_In_Place_Iface_Call_In_Anonymous_Context; 8958 8959 ---------------------------------------------------------- 8960 -- Make_Build_In_Place_Iface_Call_In_Object_Declaration -- 8961 ---------------------------------------------------------- 8962 8963 procedure Make_Build_In_Place_Iface_Call_In_Object_Declaration 8964 (Obj_Decl : Node_Id; 8965 Function_Call : Node_Id) 8966 is 8967 BIP_Func_Call : constant Node_Id := 8968 Unqual_BIP_Iface_Function_Call (Function_Call); 8969 Loc : constant Source_Ptr := Sloc (Function_Call); 8970 Obj_Id : constant Entity_Id := Defining_Entity (Obj_Decl); 8971 8972 Tmp_Decl : Node_Id; 8973 Tmp_Id : Entity_Id; 8974 8975 begin 8976 -- No action of the call has already been processed 8977 8978 if Is_Expanded_Build_In_Place_Call (BIP_Func_Call) then 8979 return; 8980 end if; 8981 8982 Tmp_Id := Make_Temporary (Loc, 'D'); 8983 8984 -- Insert a temporary before N initialized with the BIP function call 8985 -- without its enclosing type conversions and analyze it without its 8986 -- expansion. This temporary facilitates us reusing the BIP machinery, 8987 -- which takes care of adding the extra build-in-place actuals and 8988 -- transforms this object declaration into an object renaming 8989 -- declaration. 8990 8991 Tmp_Decl := 8992 Make_Object_Declaration (Loc, 8993 Defining_Identifier => Tmp_Id, 8994 Object_Definition => 8995 New_Occurrence_Of (Etype (BIP_Func_Call), Loc), 8996 Expression => New_Copy_Tree (BIP_Func_Call)); 8997 8998 Expander_Mode_Save_And_Set (False); 8999 Insert_Action (Obj_Decl, Tmp_Decl); 9000 Expander_Mode_Restore; 9001 9002 Make_Build_In_Place_Call_In_Object_Declaration 9003 (Obj_Decl => Tmp_Decl, 9004 Function_Call => Expression (Tmp_Decl)); 9005 9006 pragma Assert (Nkind (Tmp_Decl) = N_Object_Renaming_Declaration); 9007 9008 -- Replace the original build-in-place function call by a reference to 9009 -- the resulting temporary object renaming declaration. In this way, 9010 -- all the interface conversions performed in the original Function_Call 9011 -- on the build-in-place object are preserved. 9012 9013 Rewrite (BIP_Func_Call, New_Occurrence_Of (Tmp_Id, Loc)); 9014 9015 -- Replace the original object declaration by an internal object 9016 -- renaming declaration. This leaves the generated code more clean (the 9017 -- build-in-place function call in an object renaming declaration and 9018 -- displacements of the pointer to the build-in-place object in another 9019 -- renaming declaration) and allows us to invoke the routine that takes 9020 -- care of replacing the identifier of the renaming declaration (routine 9021 -- originally developed for the regular build-in-place management). 9022 9023 Rewrite (Obj_Decl, 9024 Make_Object_Renaming_Declaration (Loc, 9025 Defining_Identifier => Make_Temporary (Loc, 'D'), 9026 Subtype_Mark => New_Occurrence_Of (Etype (Obj_Id), Loc), 9027 Name => Function_Call)); 9028 Analyze (Obj_Decl); 9029 9030 Replace_Renaming_Declaration_Id (Obj_Decl, Original_Node (Obj_Decl)); 9031 end Make_Build_In_Place_Iface_Call_In_Object_Declaration; 9032 9033 -------------------------------------------- 9034 -- Make_CPP_Constructor_Call_In_Allocator -- 9035 -------------------------------------------- 9036 9037 procedure Make_CPP_Constructor_Call_In_Allocator 9038 (Allocator : Node_Id; 9039 Function_Call : Node_Id) 9040 is 9041 Loc : constant Source_Ptr := Sloc (Function_Call); 9042 Acc_Type : constant Entity_Id := Etype (Allocator); 9043 Function_Id : constant Entity_Id := Entity (Name (Function_Call)); 9044 Result_Subt : constant Entity_Id := Available_View (Etype (Function_Id)); 9045 9046 New_Allocator : Node_Id; 9047 Return_Obj_Access : Entity_Id; 9048 Tmp_Obj : Node_Id; 9049 9050 begin 9051 pragma Assert (Nkind (Allocator) = N_Allocator 9052 and then Nkind (Function_Call) = N_Function_Call); 9053 pragma Assert (Convention (Function_Id) = Convention_CPP 9054 and then Is_Constructor (Function_Id)); 9055 pragma Assert (Is_Constrained (Underlying_Type (Result_Subt))); 9056 9057 -- Replace the initialized allocator of form "new T'(Func (...))" with 9058 -- an uninitialized allocator of form "new T", where T is the result 9059 -- subtype of the called function. The call to the function is handled 9060 -- separately further below. 9061 9062 New_Allocator := 9063 Make_Allocator (Loc, 9064 Expression => New_Occurrence_Of (Result_Subt, Loc)); 9065 Set_No_Initialization (New_Allocator); 9066 9067 -- Copy attributes to new allocator. Note that the new allocator 9068 -- logically comes from source if the original one did, so copy the 9069 -- relevant flag. This ensures proper treatment of the restriction 9070 -- No_Implicit_Heap_Allocations in this case. 9071 9072 Set_Storage_Pool (New_Allocator, Storage_Pool (Allocator)); 9073 Set_Procedure_To_Call (New_Allocator, Procedure_To_Call (Allocator)); 9074 Set_Comes_From_Source (New_Allocator, Comes_From_Source (Allocator)); 9075 9076 Rewrite (Allocator, New_Allocator); 9077 9078 -- Create a new access object and initialize it to the result of the 9079 -- new uninitialized allocator. Note: we do not use Allocator as the 9080 -- Related_Node of Return_Obj_Access in call to Make_Temporary below 9081 -- as this would create a sort of infinite "recursion". 9082 9083 Return_Obj_Access := Make_Temporary (Loc, 'R'); 9084 Set_Etype (Return_Obj_Access, Acc_Type); 9085 9086 -- Generate: 9087 -- Rnnn : constant ptr_T := new (T); 9088 -- Init (Rnn.all,...); 9089 9090 Tmp_Obj := 9091 Make_Object_Declaration (Loc, 9092 Defining_Identifier => Return_Obj_Access, 9093 Constant_Present => True, 9094 Object_Definition => New_Occurrence_Of (Acc_Type, Loc), 9095 Expression => Relocate_Node (Allocator)); 9096 Insert_Action (Allocator, Tmp_Obj); 9097 9098 Insert_List_After_And_Analyze (Tmp_Obj, 9099 Build_Initialization_Call (Loc, 9100 Id_Ref => 9101 Make_Explicit_Dereference (Loc, 9102 Prefix => New_Occurrence_Of (Return_Obj_Access, Loc)), 9103 Typ => Etype (Function_Id), 9104 Constructor_Ref => Function_Call)); 9105 9106 -- Finally, replace the allocator node with a reference to the result of 9107 -- the function call itself (which will effectively be an access to the 9108 -- object created by the allocator). 9109 9110 Rewrite (Allocator, New_Occurrence_Of (Return_Obj_Access, Loc)); 9111 9112 -- Ada 2005 (AI-251): If the type of the allocator is an interface then 9113 -- generate an implicit conversion to force displacement of the "this" 9114 -- pointer. 9115 9116 if Is_Interface (Designated_Type (Acc_Type)) then 9117 Rewrite (Allocator, Convert_To (Acc_Type, Relocate_Node (Allocator))); 9118 end if; 9119 9120 Analyze_And_Resolve (Allocator, Acc_Type); 9121 end Make_CPP_Constructor_Call_In_Allocator; 9122 9123 ----------------------------------- 9124 -- Needs_BIP_Finalization_Master -- 9125 ----------------------------------- 9126 9127 function Needs_BIP_Finalization_Master 9128 (Func_Id : Entity_Id) return Boolean 9129 is 9130 pragma Assert (Is_Build_In_Place_Function (Func_Id)); 9131 Func_Typ : constant Entity_Id := Underlying_Type (Etype (Func_Id)); 9132 begin 9133 -- A formal giving the finalization master is needed for build-in-place 9134 -- functions whose result type needs finalization or is a tagged type. 9135 -- Tagged primitive build-in-place functions need such a formal because 9136 -- they can be called by a dispatching call, and extensions may require 9137 -- finalization even if the root type doesn't. This means they're also 9138 -- needed for tagged nonprimitive build-in-place functions with tagged 9139 -- results, since such functions can be called via access-to-function 9140 -- types, and those can be used to call primitives, so masters have to 9141 -- be passed to all such build-in-place functions, primitive or not. 9142 9143 return 9144 not Restriction_Active (No_Finalization) 9145 and then (Needs_Finalization (Func_Typ) 9146 or else Is_Tagged_Type (Func_Typ)); 9147 end Needs_BIP_Finalization_Master; 9148 9149 -------------------------- 9150 -- Needs_BIP_Alloc_Form -- 9151 -------------------------- 9152 9153 function Needs_BIP_Alloc_Form (Func_Id : Entity_Id) return Boolean is 9154 pragma Assert (Is_Build_In_Place_Function (Func_Id)); 9155 Func_Typ : constant Entity_Id := Underlying_Type (Etype (Func_Id)); 9156 9157 begin 9158 -- A build-in-place function needs to know which allocation form to 9159 -- use when: 9160 -- 9161 -- 1) The result subtype is unconstrained. In this case, depending on 9162 -- the context of the call, the object may need to be created in the 9163 -- secondary stack, the heap, or a user-defined storage pool. 9164 -- 9165 -- 2) The result subtype is tagged. In this case the function call may 9166 -- dispatch on result and thus needs to be treated in the same way as 9167 -- calls to functions with class-wide results, because a callee that 9168 -- can be dispatched to may have any of various result subtypes, so 9169 -- if any of the possible callees would require an allocation form to 9170 -- be passed then they all do. 9171 -- 9172 -- 3) The result subtype needs finalization actions. In this case, based 9173 -- on the context of the call, the object may need to be created at 9174 -- the caller site, in the heap, or in a user-defined storage pool. 9175 9176 return 9177 not Is_Constrained (Func_Typ) 9178 or else Is_Tagged_Type (Func_Typ) 9179 or else Needs_Finalization (Func_Typ); 9180 end Needs_BIP_Alloc_Form; 9181 9182 -------------------------------------- 9183 -- Needs_Result_Accessibility_Level -- 9184 -------------------------------------- 9185 9186 function Needs_Result_Accessibility_Level 9187 (Func_Id : Entity_Id) return Boolean 9188 is 9189 Func_Typ : constant Entity_Id := Underlying_Type (Etype (Func_Id)); 9190 9191 function Has_Unconstrained_Access_Discriminant_Component 9192 (Comp_Typ : Entity_Id) return Boolean; 9193 -- Returns True if any component of the type has an unconstrained access 9194 -- discriminant. 9195 9196 ----------------------------------------------------- 9197 -- Has_Unconstrained_Access_Discriminant_Component -- 9198 ----------------------------------------------------- 9199 9200 function Has_Unconstrained_Access_Discriminant_Component 9201 (Comp_Typ : Entity_Id) return Boolean 9202 is 9203 begin 9204 if not Is_Limited_Type (Comp_Typ) then 9205 return False; 9206 9207 -- Only limited types can have access discriminants with 9208 -- defaults. 9209 9210 elsif Has_Unconstrained_Access_Discriminants (Comp_Typ) then 9211 return True; 9212 9213 elsif Is_Array_Type (Comp_Typ) then 9214 return Has_Unconstrained_Access_Discriminant_Component 9215 (Underlying_Type (Component_Type (Comp_Typ))); 9216 9217 elsif Is_Record_Type (Comp_Typ) then 9218 declare 9219 Comp : Entity_Id; 9220 9221 begin 9222 Comp := First_Component (Comp_Typ); 9223 while Present (Comp) loop 9224 if Has_Unconstrained_Access_Discriminant_Component 9225 (Underlying_Type (Etype (Comp))) 9226 then 9227 return True; 9228 end if; 9229 9230 Next_Component (Comp); 9231 end loop; 9232 end; 9233 end if; 9234 9235 return False; 9236 end Has_Unconstrained_Access_Discriminant_Component; 9237 9238 Feature_Disabled : constant Boolean := True; 9239 -- Temporary 9240 9241 -- Start of processing for Needs_Result_Accessibility_Level 9242 9243 begin 9244 -- False if completion unavailable (how does this happen???) 9245 9246 if not Present (Func_Typ) then 9247 return False; 9248 9249 elsif Feature_Disabled then 9250 return False; 9251 9252 -- False if not a function, also handle enum-lit renames case 9253 9254 elsif Func_Typ = Standard_Void_Type 9255 or else Is_Scalar_Type (Func_Typ) 9256 then 9257 return False; 9258 9259 -- Handle a corner case, a cross-dialect subp renaming. For example, 9260 -- an Ada 2012 renaming of an Ada 2005 subprogram. This can occur when 9261 -- an Ada 2005 (or earlier) unit references predefined run-time units. 9262 9263 elsif Present (Alias (Func_Id)) then 9264 9265 -- Unimplemented: a cross-dialect subp renaming which does not set 9266 -- the Alias attribute (e.g., a rename of a dereference of an access 9267 -- to subprogram value). ??? 9268 9269 return Present (Extra_Accessibility_Of_Result (Alias (Func_Id))); 9270 9271 -- Remaining cases require Ada 2012 mode 9272 9273 elsif Ada_Version < Ada_2012 then 9274 return False; 9275 9276 elsif Ekind (Func_Typ) = E_Anonymous_Access_Type 9277 or else Is_Tagged_Type (Func_Typ) 9278 then 9279 -- In the case of, say, a null tagged record result type, the need 9280 -- for this extra parameter might not be obvious. This function 9281 -- returns True for all tagged types for compatibility reasons. 9282 -- A function with, say, a tagged null controlling result type might 9283 -- be overridden by a primitive of an extension having an access 9284 -- discriminant and the overrider and overridden must have compatible 9285 -- calling conventions (including implicitly declared parameters). 9286 -- Similarly, values of one access-to-subprogram type might designate 9287 -- both a primitive subprogram of a given type and a function 9288 -- which is, for example, not a primitive subprogram of any type. 9289 -- Again, this requires calling convention compatibility. 9290 -- It might be possible to solve these issues by introducing 9291 -- wrappers, but that is not the approach that was chosen. 9292 9293 return True; 9294 9295 elsif Has_Unconstrained_Access_Discriminants (Func_Typ) then 9296 return True; 9297 9298 elsif Has_Unconstrained_Access_Discriminant_Component (Func_Typ) then 9299 return True; 9300 9301 -- False for all other cases 9302 9303 else 9304 return False; 9305 end if; 9306 end Needs_Result_Accessibility_Level; 9307 9308 ------------------------------------- 9309 -- Replace_Renaming_Declaration_Id -- 9310 ------------------------------------- 9311 9312 procedure Replace_Renaming_Declaration_Id 9313 (New_Decl : Node_Id; 9314 Orig_Decl : Node_Id) 9315 is 9316 New_Id : constant Entity_Id := Defining_Entity (New_Decl); 9317 Orig_Id : constant Entity_Id := Defining_Entity (Orig_Decl); 9318 9319 begin 9320 Set_Chars (New_Id, Chars (Orig_Id)); 9321 9322 -- Swap next entity links in preparation for exchanging entities 9323 9324 declare 9325 Next_Id : constant Entity_Id := Next_Entity (New_Id); 9326 begin 9327 Link_Entities (New_Id, Next_Entity (Orig_Id)); 9328 Link_Entities (Orig_Id, Next_Id); 9329 end; 9330 9331 Set_Homonym (New_Id, Homonym (Orig_Id)); 9332 Exchange_Entities (New_Id, Orig_Id); 9333 9334 -- Preserve source indication of original declaration, so that xref 9335 -- information is properly generated for the right entity. 9336 9337 Preserve_Comes_From_Source (New_Decl, Orig_Decl); 9338 Preserve_Comes_From_Source (Orig_Id, Orig_Decl); 9339 9340 Set_Comes_From_Source (New_Id, False); 9341 end Replace_Renaming_Declaration_Id; 9342 9343 --------------------------------- 9344 -- Rewrite_Function_Call_For_C -- 9345 --------------------------------- 9346 9347 procedure Rewrite_Function_Call_For_C (N : Node_Id) is 9348 Orig_Func : constant Entity_Id := Entity (Name (N)); 9349 Func_Id : constant Entity_Id := Ultimate_Alias (Orig_Func); 9350 Par : constant Node_Id := Parent (N); 9351 Proc_Id : constant Entity_Id := Corresponding_Procedure (Func_Id); 9352 Loc : constant Source_Ptr := Sloc (Par); 9353 Actuals : List_Id; 9354 Last_Actual : Node_Id; 9355 Last_Formal : Entity_Id; 9356 9357 -- Start of processing for Rewrite_Function_Call_For_C 9358 9359 begin 9360 -- The actuals may be given by named associations, so the added actual 9361 -- that is the target of the return value of the call must be a named 9362 -- association as well, so we retrieve the name of the generated 9363 -- out_formal. 9364 9365 Last_Formal := First_Formal (Proc_Id); 9366 while Present (Next_Formal (Last_Formal)) loop 9367 Last_Formal := Next_Formal (Last_Formal); 9368 end loop; 9369 9370 Actuals := Parameter_Associations (N); 9371 9372 -- The original function may lack parameters 9373 9374 if No (Actuals) then 9375 Actuals := New_List; 9376 end if; 9377 9378 -- If the function call is the expression of an assignment statement, 9379 -- transform the assignment into a procedure call. Generate: 9380 9381 -- LHS := Func_Call (...); 9382 9383 -- Proc_Call (..., LHS); 9384 9385 -- If function is inherited, a conversion may be necessary. 9386 9387 if Nkind (Par) = N_Assignment_Statement then 9388 Last_Actual := Name (Par); 9389 9390 if not Comes_From_Source (Orig_Func) 9391 and then Etype (Orig_Func) /= Etype (Func_Id) 9392 then 9393 Last_Actual := 9394 Make_Type_Conversion (Loc, 9395 New_Occurrence_Of (Etype (Func_Id), Loc), 9396 Last_Actual); 9397 end if; 9398 9399 Append_To (Actuals, 9400 Make_Parameter_Association (Loc, 9401 Selector_Name => 9402 Make_Identifier (Loc, Chars (Last_Formal)), 9403 Explicit_Actual_Parameter => Last_Actual)); 9404 9405 Rewrite (Par, 9406 Make_Procedure_Call_Statement (Loc, 9407 Name => New_Occurrence_Of (Proc_Id, Loc), 9408 Parameter_Associations => Actuals)); 9409 Analyze (Par); 9410 9411 -- Otherwise the context is an expression. Generate a temporary and a 9412 -- procedure call to obtain the function result. Generate: 9413 9414 -- ... Func_Call (...) ... 9415 9416 -- Temp : ...; 9417 -- Proc_Call (..., Temp); 9418 -- ... Temp ... 9419 9420 else 9421 declare 9422 Temp_Id : constant Entity_Id := Make_Temporary (Loc, 'T'); 9423 Call : Node_Id; 9424 Decl : Node_Id; 9425 9426 begin 9427 -- Generate: 9428 -- Temp : ...; 9429 9430 Decl := 9431 Make_Object_Declaration (Loc, 9432 Defining_Identifier => Temp_Id, 9433 Object_Definition => 9434 New_Occurrence_Of (Etype (Func_Id), Loc)); 9435 9436 -- Generate: 9437 -- Proc_Call (..., Temp); 9438 9439 Append_To (Actuals, 9440 Make_Parameter_Association (Loc, 9441 Selector_Name => 9442 Make_Identifier (Loc, Chars (Last_Formal)), 9443 Explicit_Actual_Parameter => 9444 New_Occurrence_Of (Temp_Id, Loc))); 9445 9446 Call := 9447 Make_Procedure_Call_Statement (Loc, 9448 Name => New_Occurrence_Of (Proc_Id, Loc), 9449 Parameter_Associations => Actuals); 9450 9451 Insert_Actions (Par, New_List (Decl, Call)); 9452 Rewrite (N, New_Occurrence_Of (Temp_Id, Loc)); 9453 end; 9454 end if; 9455 end Rewrite_Function_Call_For_C; 9456 9457 ------------------------------------ 9458 -- Set_Enclosing_Sec_Stack_Return -- 9459 ------------------------------------ 9460 9461 procedure Set_Enclosing_Sec_Stack_Return (N : Node_Id) is 9462 P : Node_Id := N; 9463 9464 begin 9465 -- Due to a possible mix of internally generated blocks, source blocks 9466 -- and loops, the scope stack may not be contiguous as all labels are 9467 -- inserted at the top level within the related function. Instead, 9468 -- perform a parent-based traversal and mark all appropriate constructs. 9469 9470 while Present (P) loop 9471 9472 -- Mark the label of a source or internally generated block or 9473 -- loop. 9474 9475 if Nkind_In (P, N_Block_Statement, N_Loop_Statement) then 9476 Set_Sec_Stack_Needed_For_Return (Entity (Identifier (P))); 9477 9478 -- Mark the enclosing function 9479 9480 elsif Nkind (P) = N_Subprogram_Body then 9481 if Present (Corresponding_Spec (P)) then 9482 Set_Sec_Stack_Needed_For_Return (Corresponding_Spec (P)); 9483 else 9484 Set_Sec_Stack_Needed_For_Return (Defining_Entity (P)); 9485 end if; 9486 9487 -- Do not go beyond the enclosing function 9488 9489 exit; 9490 end if; 9491 9492 P := Parent (P); 9493 end loop; 9494 end Set_Enclosing_Sec_Stack_Return; 9495 9496 ------------------------------------ 9497 -- Unqual_BIP_Iface_Function_Call -- 9498 ------------------------------------ 9499 9500 function Unqual_BIP_Iface_Function_Call (Expr : Node_Id) return Node_Id is 9501 Has_Pointer_Displacement : Boolean := False; 9502 On_Object_Declaration : Boolean := False; 9503 -- Remember if processing the renaming expressions on recursion we have 9504 -- traversed an object declaration, since we can traverse many object 9505 -- declaration renamings but just one regular object declaration. 9506 9507 function Unqual_BIP_Function_Call (Expr : Node_Id) return Node_Id; 9508 -- Search for a build-in-place function call skipping any qualification 9509 -- including qualified expressions, type conversions, references, calls 9510 -- to displace the pointer to the object, and renamings. Return Empty if 9511 -- no build-in-place function call is found. 9512 9513 ------------------------------ 9514 -- Unqual_BIP_Function_Call -- 9515 ------------------------------ 9516 9517 function Unqual_BIP_Function_Call (Expr : Node_Id) return Node_Id is 9518 begin 9519 -- Recurse to handle case of multiple levels of qualification and/or 9520 -- conversion. 9521 9522 if Nkind_In (Expr, N_Qualified_Expression, 9523 N_Type_Conversion, 9524 N_Unchecked_Type_Conversion) 9525 then 9526 return Unqual_BIP_Function_Call (Expression (Expr)); 9527 9528 -- Recurse to handle case of multiple levels of references and 9529 -- explicit dereferences. 9530 9531 elsif Nkind_In (Expr, N_Attribute_Reference, 9532 N_Explicit_Dereference, 9533 N_Reference) 9534 then 9535 return Unqual_BIP_Function_Call (Prefix (Expr)); 9536 9537 -- Recurse on object renamings 9538 9539 elsif Nkind (Expr) = N_Identifier 9540 and then Present (Entity (Expr)) 9541 and then Ekind_In (Entity (Expr), E_Constant, E_Variable) 9542 and then Nkind (Parent (Entity (Expr))) = 9543 N_Object_Renaming_Declaration 9544 and then Present (Renamed_Object (Entity (Expr))) 9545 then 9546 return Unqual_BIP_Function_Call (Renamed_Object (Entity (Expr))); 9547 9548 -- Recurse on the initializing expression of the first reference of 9549 -- an object declaration. 9550 9551 elsif not On_Object_Declaration 9552 and then Nkind (Expr) = N_Identifier 9553 and then Present (Entity (Expr)) 9554 and then Ekind_In (Entity (Expr), E_Constant, E_Variable) 9555 and then Nkind (Parent (Entity (Expr))) = N_Object_Declaration 9556 and then Present (Expression (Parent (Entity (Expr)))) 9557 then 9558 On_Object_Declaration := True; 9559 return 9560 Unqual_BIP_Function_Call (Expression (Parent (Entity (Expr)))); 9561 9562 -- Recurse to handle calls to displace the pointer to the object to 9563 -- reference a secondary dispatch table. 9564 9565 elsif Nkind (Expr) = N_Function_Call 9566 and then Nkind (Name (Expr)) in N_Has_Entity 9567 and then Present (Entity (Name (Expr))) 9568 and then RTU_Loaded (Ada_Tags) 9569 and then RTE_Available (RE_Displace) 9570 and then Is_RTE (Entity (Name (Expr)), RE_Displace) 9571 then 9572 Has_Pointer_Displacement := True; 9573 return 9574 Unqual_BIP_Function_Call (First (Parameter_Associations (Expr))); 9575 9576 -- Normal case: check if the inner expression is a BIP function call 9577 -- and the pointer to the object is displaced. 9578 9579 elsif Has_Pointer_Displacement 9580 and then Is_Build_In_Place_Function_Call (Expr) 9581 then 9582 return Expr; 9583 9584 else 9585 return Empty; 9586 end if; 9587 end Unqual_BIP_Function_Call; 9588 9589 -- Start of processing for Unqual_BIP_Iface_Function_Call 9590 9591 begin 9592 if Nkind (Expr) = N_Identifier and then No (Entity (Expr)) then 9593 9594 -- Can happen for X'Elab_Spec in the binder-generated file 9595 9596 return Empty; 9597 end if; 9598 9599 return Unqual_BIP_Function_Call (Expr); 9600 end Unqual_BIP_Iface_Function_Call; 9601 9602end Exp_Ch6; 9603