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