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