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