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