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