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