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