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-2003, 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 2, 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 COPYING. If not, write -- 19-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- 20-- MA 02111-1307, USA. -- 21-- -- 22-- GNAT was originally developed by the GNAT team at New York University. -- 23-- Extensive contributions were provided by Ada Core Technologies Inc. -- 24-- -- 25------------------------------------------------------------------------------ 26 27with Atree; use Atree; 28with Checks; use Checks; 29with Debug; use Debug; 30with Einfo; use Einfo; 31with Errout; use Errout; 32with Elists; use Elists; 33with Exp_Ch2; use Exp_Ch2; 34with Exp_Ch3; use Exp_Ch3; 35with Exp_Ch7; use Exp_Ch7; 36with Exp_Ch9; use Exp_Ch9; 37with Exp_Ch11; use Exp_Ch11; 38with Exp_Dbug; use Exp_Dbug; 39with Exp_Disp; use Exp_Disp; 40with Exp_Dist; use Exp_Dist; 41with Exp_Intr; use Exp_Intr; 42with Exp_Pakd; use Exp_Pakd; 43with Exp_Tss; use Exp_Tss; 44with Exp_Util; use Exp_Util; 45with Fname; use Fname; 46with Freeze; use Freeze; 47with Hostparm; use Hostparm; 48with Inline; use Inline; 49with Lib; use Lib; 50with Nlists; use Nlists; 51with Nmake; use Nmake; 52with Opt; use Opt; 53with Restrict; use Restrict; 54with Rtsfind; use Rtsfind; 55with Sem; use Sem; 56with Sem_Ch6; use Sem_Ch6; 57with Sem_Ch8; use Sem_Ch8; 58with Sem_Ch12; use Sem_Ch12; 59with Sem_Ch13; use Sem_Ch13; 60with Sem_Disp; use Sem_Disp; 61with Sem_Dist; use Sem_Dist; 62with Sem_Res; use Sem_Res; 63with Sem_Util; use Sem_Util; 64with Sinfo; use Sinfo; 65with Snames; use Snames; 66with Stand; use Stand; 67with Tbuild; use Tbuild; 68with Ttypes; use Ttypes; 69with Uintp; use Uintp; 70with Validsw; use Validsw; 71 72package body Exp_Ch6 is 73 74 ----------------------- 75 -- Local Subprograms -- 76 ----------------------- 77 78 procedure Check_Overriding_Operation (Subp : Entity_Id); 79 -- Subp is a dispatching operation. Check whether it may override an 80 -- inherited private operation, in which case its DT entry is that of 81 -- the hidden operation, not the one it may have received earlier. 82 -- This must be done before emitting the code to set the corresponding 83 -- DT to the address of the subprogram. The actual placement of Subp in 84 -- the proper place in the list of primitive operations is done in 85 -- Declare_Inherited_Private_Subprograms, which also has to deal with 86 -- implicit operations. This duplication is unavoidable for now??? 87 88 procedure Detect_Infinite_Recursion (N : Node_Id; Spec : Entity_Id); 89 -- This procedure is called only if the subprogram body N, whose spec 90 -- has the given entity Spec, contains a parameterless recursive call. 91 -- It attempts to generate runtime code to detect if this a case of 92 -- infinite recursion. 93 -- 94 -- The body is scanned to determine dependencies. If the only external 95 -- dependencies are on a small set of scalar variables, then the values 96 -- of these variables are captured on entry to the subprogram, and if 97 -- the values are not changed for the call, we know immediately that 98 -- we have an infinite recursion. 99 100 procedure Expand_Actuals (N : Node_Id; Subp : Entity_Id); 101 -- For each actual of an in-out parameter which is a numeric conversion 102 -- of the form T(A), where A denotes a variable, we insert the declaration: 103 -- 104 -- Temp : T := T (A); 105 -- 106 -- prior to the call. Then we replace the actual with a reference to Temp, 107 -- and append the assignment: 108 -- 109 -- A := TypeA (Temp); 110 -- 111 -- after the call. Here TypeA is the actual type of variable A. 112 -- For out parameters, the initial declaration has no expression. 113 -- If A is not an entity name, we generate instead: 114 -- 115 -- Var : TypeA renames A; 116 -- Temp : T := Var; -- omitting expression for out parameter. 117 -- ... 118 -- Var := TypeA (Temp); 119 -- 120 -- For other in-out parameters, we emit the required constraint checks 121 -- before and/or after the call. 122 -- 123 -- For all parameter modes, actuals that denote components and slices 124 -- of packed arrays are expanded into suitable temporaries. 125 126 procedure Expand_Inlined_Call 127 (N : Node_Id; 128 Subp : Entity_Id; 129 Orig_Subp : Entity_Id); 130 -- If called subprogram can be inlined by the front-end, retrieve the 131 -- analyzed body, replace formals with actuals and expand call in place. 132 -- Generate thunks for actuals that are expressions, and insert the 133 -- corresponding constant declarations before the call. If the original 134 -- call is to a derived operation, the return type is the one of the 135 -- derived operation, but the body is that of the original, so return 136 -- expressions in the body must be converted to the desired type (which 137 -- is simply not noted in the tree without inline expansion). 138 139 function Expand_Protected_Object_Reference 140 (N : Node_Id; 141 Scop : Entity_Id) 142 return Node_Id; 143 144 procedure Expand_Protected_Subprogram_Call 145 (N : Node_Id; 146 Subp : Entity_Id; 147 Scop : Entity_Id); 148 -- A call to a protected subprogram within the protected object may appear 149 -- as a regular call. The list of actuals must be expanded to contain a 150 -- reference to the object itself, and the call becomes a call to the 151 -- corresponding protected subprogram. 152 153 -------------------------------- 154 -- Check_Overriding_Operation -- 155 -------------------------------- 156 157 procedure Check_Overriding_Operation (Subp : Entity_Id) is 158 Typ : constant Entity_Id := Find_Dispatching_Type (Subp); 159 Op_List : constant Elist_Id := Primitive_Operations (Typ); 160 Op_Elmt : Elmt_Id; 161 Prim_Op : Entity_Id; 162 Par_Op : Entity_Id; 163 164 begin 165 if Is_Derived_Type (Typ) 166 and then not Is_Private_Type (Typ) 167 and then In_Open_Scopes (Scope (Etype (Typ))) 168 and then Typ = Base_Type (Typ) 169 then 170 -- Subp overrides an inherited private operation if there is 171 -- an inherited operation with a different name than Subp (see 172 -- Derive_Subprogram) whose Alias is a hidden subprogram with 173 -- the same name as Subp. 174 175 Op_Elmt := First_Elmt (Op_List); 176 while Present (Op_Elmt) loop 177 Prim_Op := Node (Op_Elmt); 178 Par_Op := Alias (Prim_Op); 179 180 if Present (Par_Op) 181 and then not Comes_From_Source (Prim_Op) 182 and then Chars (Prim_Op) /= Chars (Par_Op) 183 and then Chars (Par_Op) = Chars (Subp) 184 and then Is_Hidden (Par_Op) 185 and then Type_Conformant (Prim_Op, Subp) 186 then 187 Set_DT_Position (Subp, DT_Position (Prim_Op)); 188 end if; 189 190 Next_Elmt (Op_Elmt); 191 end loop; 192 end if; 193 end Check_Overriding_Operation; 194 195 ------------------------------- 196 -- Detect_Infinite_Recursion -- 197 ------------------------------- 198 199 procedure Detect_Infinite_Recursion (N : Node_Id; Spec : Entity_Id) is 200 Loc : constant Source_Ptr := Sloc (N); 201 202 Var_List : constant Elist_Id := New_Elmt_List; 203 -- List of globals referenced by body of procedure 204 205 Call_List : constant Elist_Id := New_Elmt_List; 206 -- List of recursive calls in body of procedure 207 208 Shad_List : constant Elist_Id := New_Elmt_List; 209 -- List of entity id's for entities created to capture the 210 -- value of referenced globals on entry to the procedure. 211 212 Scop : constant Uint := Scope_Depth (Spec); 213 -- This is used to record the scope depth of the current 214 -- procedure, so that we can identify global references. 215 216 Max_Vars : constant := 4; 217 -- Do not test more than four global variables 218 219 Count_Vars : Natural := 0; 220 -- Count variables found so far 221 222 Var : Entity_Id; 223 Elm : Elmt_Id; 224 Ent : Entity_Id; 225 Call : Elmt_Id; 226 Decl : Node_Id; 227 Test : Node_Id; 228 Elm1 : Elmt_Id; 229 Elm2 : Elmt_Id; 230 Last : Node_Id; 231 232 function Process (Nod : Node_Id) return Traverse_Result; 233 -- Function to traverse the subprogram body (using Traverse_Func) 234 235 ------------- 236 -- Process -- 237 ------------- 238 239 function Process (Nod : Node_Id) return Traverse_Result is 240 begin 241 -- Procedure call 242 243 if Nkind (Nod) = N_Procedure_Call_Statement then 244 245 -- Case of one of the detected recursive calls 246 247 if Is_Entity_Name (Name (Nod)) 248 and then Has_Recursive_Call (Entity (Name (Nod))) 249 and then Entity (Name (Nod)) = Spec 250 then 251 Append_Elmt (Nod, Call_List); 252 return Skip; 253 254 -- Any other procedure call may have side effects 255 256 else 257 return Abandon; 258 end if; 259 260 -- A call to a pure function can always be ignored 261 262 elsif Nkind (Nod) = N_Function_Call 263 and then Is_Entity_Name (Name (Nod)) 264 and then Is_Pure (Entity (Name (Nod))) 265 then 266 return Skip; 267 268 -- Case of an identifier reference 269 270 elsif Nkind (Nod) = N_Identifier then 271 Ent := Entity (Nod); 272 273 -- If no entity, then ignore the reference 274 275 -- Not clear why this can happen. To investigate, remove this 276 -- test and look at the crash that occurs here in 3401-004 ??? 277 278 if No (Ent) then 279 return Skip; 280 281 -- Ignore entities with no Scope, again not clear how this 282 -- can happen, to investigate, look at 4108-008 ??? 283 284 elsif No (Scope (Ent)) then 285 return Skip; 286 287 -- Ignore the reference if not to a more global object 288 289 elsif Scope_Depth (Scope (Ent)) >= Scop then 290 return Skip; 291 292 -- References to types, exceptions and constants are always OK 293 294 elsif Is_Type (Ent) 295 or else Ekind (Ent) = E_Exception 296 or else Ekind (Ent) = E_Constant 297 then 298 return Skip; 299 300 -- If other than a non-volatile scalar variable, we have some 301 -- kind of global reference (e.g. to a function) that we cannot 302 -- deal with so we forget the attempt. 303 304 elsif Ekind (Ent) /= E_Variable 305 or else not Is_Scalar_Type (Etype (Ent)) 306 or else Treat_As_Volatile (Ent) 307 then 308 return Abandon; 309 310 -- Otherwise we have a reference to a global scalar 311 312 else 313 -- Loop through global entities already detected 314 315 Elm := First_Elmt (Var_List); 316 loop 317 -- If not detected before, record this new global reference 318 319 if No (Elm) then 320 Count_Vars := Count_Vars + 1; 321 322 if Count_Vars <= Max_Vars then 323 Append_Elmt (Entity (Nod), Var_List); 324 else 325 return Abandon; 326 end if; 327 328 exit; 329 330 -- If recorded before, ignore 331 332 elsif Node (Elm) = Entity (Nod) then 333 return Skip; 334 335 -- Otherwise keep looking 336 337 else 338 Next_Elmt (Elm); 339 end if; 340 end loop; 341 342 return Skip; 343 end if; 344 345 -- For all other node kinds, recursively visit syntactic children 346 347 else 348 return OK; 349 end if; 350 end Process; 351 352 function Traverse_Body is new Traverse_Func; 353 354 -- Start of processing for Detect_Infinite_Recursion 355 356 begin 357 -- Do not attempt detection in No_Implicit_Conditional mode, 358 -- since we won't be able to generate the code to handle the 359 -- recursion in any case. 360 361 if Restrictions (No_Implicit_Conditionals) then 362 return; 363 end if; 364 365 -- Otherwise do traversal and quit if we get abandon signal 366 367 if Traverse_Body (N) = Abandon then 368 return; 369 370 -- We must have a call, since Has_Recursive_Call was set. If not 371 -- just ignore (this is only an error check, so if we have a funny 372 -- situation, due to bugs or errors, we do not want to bomb!) 373 374 elsif Is_Empty_Elmt_List (Call_List) then 375 return; 376 end if; 377 378 -- Here is the case where we detect recursion at compile time 379 380 -- Push our current scope for analyzing the declarations and 381 -- code that we will insert for the checking. 382 383 New_Scope (Spec); 384 385 -- This loop builds temporary variables for each of the 386 -- referenced globals, so that at the end of the loop the 387 -- list Shad_List contains these temporaries in one-to-one 388 -- correspondence with the elements in Var_List. 389 390 Last := Empty; 391 Elm := First_Elmt (Var_List); 392 while Present (Elm) loop 393 Var := Node (Elm); 394 Ent := 395 Make_Defining_Identifier (Loc, 396 Chars => New_Internal_Name ('S')); 397 Append_Elmt (Ent, Shad_List); 398 399 -- Insert a declaration for this temporary at the start of 400 -- the declarations for the procedure. The temporaries are 401 -- declared as constant objects initialized to the current 402 -- values of the corresponding temporaries. 403 404 Decl := 405 Make_Object_Declaration (Loc, 406 Defining_Identifier => Ent, 407 Object_Definition => New_Occurrence_Of (Etype (Var), Loc), 408 Constant_Present => True, 409 Expression => New_Occurrence_Of (Var, Loc)); 410 411 if No (Last) then 412 Prepend (Decl, Declarations (N)); 413 else 414 Insert_After (Last, Decl); 415 end if; 416 417 Last := Decl; 418 Analyze (Decl); 419 Next_Elmt (Elm); 420 end loop; 421 422 -- Loop through calls 423 424 Call := First_Elmt (Call_List); 425 while Present (Call) loop 426 427 -- Build a predicate expression of the form 428 429 -- True 430 -- and then global1 = temp1 431 -- and then global2 = temp2 432 -- ... 433 434 -- This predicate determines if any of the global values 435 -- referenced by the procedure have changed since the 436 -- current call, if not an infinite recursion is assured. 437 438 Test := New_Occurrence_Of (Standard_True, Loc); 439 440 Elm1 := First_Elmt (Var_List); 441 Elm2 := First_Elmt (Shad_List); 442 while Present (Elm1) loop 443 Test := 444 Make_And_Then (Loc, 445 Left_Opnd => Test, 446 Right_Opnd => 447 Make_Op_Eq (Loc, 448 Left_Opnd => New_Occurrence_Of (Node (Elm1), Loc), 449 Right_Opnd => New_Occurrence_Of (Node (Elm2), Loc))); 450 451 Next_Elmt (Elm1); 452 Next_Elmt (Elm2); 453 end loop; 454 455 -- Now we replace the call with the sequence 456 457 -- if no-changes (see above) then 458 -- raise Storage_Error; 459 -- else 460 -- original-call 461 -- end if; 462 463 Rewrite (Node (Call), 464 Make_If_Statement (Loc, 465 Condition => Test, 466 Then_Statements => New_List ( 467 Make_Raise_Storage_Error (Loc, 468 Reason => SE_Infinite_Recursion)), 469 470 Else_Statements => New_List ( 471 Relocate_Node (Node (Call))))); 472 473 Analyze (Node (Call)); 474 475 Next_Elmt (Call); 476 end loop; 477 478 -- Remove temporary scope stack entry used for analysis 479 480 Pop_Scope; 481 end Detect_Infinite_Recursion; 482 483 -------------------- 484 -- Expand_Actuals -- 485 -------------------- 486 487 procedure Expand_Actuals (N : Node_Id; Subp : Entity_Id) is 488 Loc : constant Source_Ptr := Sloc (N); 489 Actual : Node_Id; 490 Formal : Entity_Id; 491 N_Node : Node_Id; 492 Post_Call : List_Id; 493 E_Formal : Entity_Id; 494 495 procedure Add_Call_By_Copy_Code; 496 -- For cases where the parameter must be passed by copy, this routine 497 -- generates a temporary variable into which the actual is copied and 498 -- then passes this as the parameter. For an OUT or IN OUT parameter, 499 -- an assignment is also generated to copy the result back. The call 500 -- also takes care of any constraint checks required for the type 501 -- conversion case (on both the way in and the way out). 502 503 procedure Add_Packed_Call_By_Copy_Code; 504 -- This is used when the actual involves a reference to an element 505 -- of a packed array, where we can appropriately use a simpler 506 -- approach than the full call by copy code. We just copy the value 507 -- in and out of an appropriate temporary. 508 509 procedure Check_Fortran_Logical; 510 -- A value of type Logical that is passed through a formal parameter 511 -- must be normalized because .TRUE. usually does not have the same 512 -- representation as True. We assume that .FALSE. = False = 0. 513 -- What about functions that return a logical type ??? 514 515 function Make_Var (Actual : Node_Id) return Entity_Id; 516 -- Returns an entity that refers to the given actual parameter, 517 -- Actual (not including any type conversion). If Actual is an 518 -- entity name, then this entity is returned unchanged, otherwise 519 -- a renaming is created to provide an entity for the actual. 520 521 procedure Reset_Packed_Prefix; 522 -- The expansion of a packed array component reference is delayed in 523 -- the context of a call. Now we need to complete the expansion, so we 524 -- unmark the analyzed bits in all prefixes. 525 526 --------------------------- 527 -- Add_Call_By_Copy_Code -- 528 --------------------------- 529 530 procedure Add_Call_By_Copy_Code is 531 Expr : Node_Id; 532 Init : Node_Id; 533 Temp : Entity_Id; 534 Var : Entity_Id; 535 V_Typ : Entity_Id; 536 Crep : Boolean; 537 538 begin 539 Temp := Make_Defining_Identifier (Loc, New_Internal_Name ('T')); 540 541 if Nkind (Actual) = N_Type_Conversion then 542 V_Typ := Etype (Expression (Actual)); 543 544 -- If the formal is an (in-)out parameter, capture the name 545 -- of the variable in order to build the post-call assignment. 546 547 Var := Make_Var (Expression (Actual)); 548 549 Crep := not Same_Representation 550 (Etype (Formal), Etype (Expression (Actual))); 551 552 else 553 V_Typ := Etype (Actual); 554 Var := Make_Var (Actual); 555 Crep := False; 556 end if; 557 558 -- Setup initialization for case of in out parameter, or an out 559 -- parameter where the formal is an unconstrained array (in the 560 -- latter case, we have to pass in an object with bounds). 561 562 if Ekind (Formal) = E_In_Out_Parameter 563 or else (Is_Array_Type (Etype (Formal)) 564 and then 565 not Is_Constrained (Etype (Formal))) 566 then 567 if Nkind (Actual) = N_Type_Conversion then 568 if Conversion_OK (Actual) then 569 Init := OK_Convert_To 570 (Etype (Formal), New_Occurrence_Of (Var, Loc)); 571 else 572 Init := Convert_To 573 (Etype (Formal), New_Occurrence_Of (Var, Loc)); 574 end if; 575 else 576 Init := New_Occurrence_Of (Var, Loc); 577 end if; 578 579 -- An initialization is created for packed conversions as 580 -- actuals for out parameters to enable Make_Object_Declaration 581 -- to determine the proper subtype for N_Node. Note that this 582 -- is wasteful because the extra copying on the call side is 583 -- not required for such out parameters. ??? 584 585 elsif Ekind (Formal) = E_Out_Parameter 586 and then Nkind (Actual) = N_Type_Conversion 587 and then (Is_Bit_Packed_Array (Etype (Formal)) 588 or else 589 Is_Bit_Packed_Array (Etype (Expression (Actual)))) 590 then 591 if Conversion_OK (Actual) then 592 Init := 593 OK_Convert_To (Etype (Formal), New_Occurrence_Of (Var, Loc)); 594 else 595 Init := 596 Convert_To (Etype (Formal), New_Occurrence_Of (Var, Loc)); 597 end if; 598 else 599 Init := Empty; 600 end if; 601 602 N_Node := 603 Make_Object_Declaration (Loc, 604 Defining_Identifier => Temp, 605 Object_Definition => 606 New_Occurrence_Of (Etype (Formal), Loc), 607 Expression => Init); 608 Set_Assignment_OK (N_Node); 609 Insert_Action (N, N_Node); 610 611 -- Now, normally the deal here is that we use the defining 612 -- identifier created by that object declaration. There is 613 -- one exception to this. In the change of representation case 614 -- the above declaration will end up looking like: 615 616 -- temp : type := identifier; 617 618 -- And in this case we might as well use the identifier directly 619 -- and eliminate the temporary. Note that the analysis of the 620 -- declaration was not a waste of time in that case, since it is 621 -- what generated the necessary change of representation code. If 622 -- the change of representation introduced additional code, as in 623 -- a fixed-integer conversion, the expression is not an identifier 624 -- and must be kept. 625 626 if Crep 627 and then Present (Expression (N_Node)) 628 and then Is_Entity_Name (Expression (N_Node)) 629 then 630 Temp := Entity (Expression (N_Node)); 631 Rewrite (N_Node, Make_Null_Statement (Loc)); 632 end if; 633 634 -- For IN parameter, all we do is to replace the actual 635 636 if Ekind (Formal) = E_In_Parameter then 637 Rewrite (Actual, New_Reference_To (Temp, Loc)); 638 Analyze (Actual); 639 640 -- Processing for OUT or IN OUT parameter 641 642 else 643 -- If type conversion, use reverse conversion on exit 644 645 if Nkind (Actual) = N_Type_Conversion then 646 if Conversion_OK (Actual) then 647 Expr := OK_Convert_To (V_Typ, New_Occurrence_Of (Temp, Loc)); 648 else 649 Expr := Convert_To (V_Typ, New_Occurrence_Of (Temp, Loc)); 650 end if; 651 else 652 Expr := New_Occurrence_Of (Temp, Loc); 653 end if; 654 655 Rewrite (Actual, New_Reference_To (Temp, Loc)); 656 Analyze (Actual); 657 658 Append_To (Post_Call, 659 Make_Assignment_Statement (Loc, 660 Name => New_Occurrence_Of (Var, Loc), 661 Expression => Expr)); 662 663 Set_Assignment_OK (Name (Last (Post_Call))); 664 end if; 665 end Add_Call_By_Copy_Code; 666 667 ---------------------------------- 668 -- Add_Packed_Call_By_Copy_Code -- 669 ---------------------------------- 670 671 procedure Add_Packed_Call_By_Copy_Code is 672 Temp : Entity_Id; 673 Incod : Node_Id; 674 Outcod : Node_Id; 675 Lhs : Node_Id; 676 Rhs : Node_Id; 677 678 begin 679 Reset_Packed_Prefix; 680 681 -- Prepare to generate code 682 683 Temp := Make_Defining_Identifier (Loc, New_Internal_Name ('T')); 684 Incod := Relocate_Node (Actual); 685 Outcod := New_Copy_Tree (Incod); 686 687 -- Generate declaration of temporary variable, initializing it 688 -- with the input parameter unless we have an OUT variable. 689 690 if Ekind (Formal) = E_Out_Parameter then 691 Incod := Empty; 692 end if; 693 694 Insert_Action (N, 695 Make_Object_Declaration (Loc, 696 Defining_Identifier => Temp, 697 Object_Definition => 698 New_Occurrence_Of (Etype (Formal), Loc), 699 Expression => Incod)); 700 701 -- The actual is simply a reference to the temporary 702 703 Rewrite (Actual, New_Occurrence_Of (Temp, Loc)); 704 705 -- Generate copy out if OUT or IN OUT parameter 706 707 if Ekind (Formal) /= E_In_Parameter then 708 Lhs := Outcod; 709 Rhs := New_Occurrence_Of (Temp, Loc); 710 711 -- Deal with conversion 712 713 if Nkind (Lhs) = N_Type_Conversion then 714 Lhs := Expression (Lhs); 715 Rhs := Convert_To (Etype (Actual), Rhs); 716 end if; 717 718 Append_To (Post_Call, 719 Make_Assignment_Statement (Loc, 720 Name => Lhs, 721 Expression => Rhs)); 722 end if; 723 end Add_Packed_Call_By_Copy_Code; 724 725 --------------------------- 726 -- Check_Fortran_Logical -- 727 --------------------------- 728 729 procedure Check_Fortran_Logical is 730 Logical : constant Entity_Id := Etype (Formal); 731 Var : Entity_Id; 732 733 -- Note: this is very incomplete, e.g. it does not handle arrays 734 -- of logical values. This is really not the right approach at all???) 735 736 begin 737 if Convention (Subp) = Convention_Fortran 738 and then Root_Type (Etype (Formal)) = Standard_Boolean 739 and then Ekind (Formal) /= E_In_Parameter 740 then 741 Var := Make_Var (Actual); 742 Append_To (Post_Call, 743 Make_Assignment_Statement (Loc, 744 Name => New_Occurrence_Of (Var, Loc), 745 Expression => 746 Unchecked_Convert_To ( 747 Logical, 748 Make_Op_Ne (Loc, 749 Left_Opnd => New_Occurrence_Of (Var, Loc), 750 Right_Opnd => 751 Unchecked_Convert_To ( 752 Logical, 753 New_Occurrence_Of (Standard_False, Loc)))))); 754 end if; 755 end Check_Fortran_Logical; 756 757 -------------- 758 -- Make_Var -- 759 -------------- 760 761 function Make_Var (Actual : Node_Id) return Entity_Id is 762 Var : Entity_Id; 763 764 begin 765 if Is_Entity_Name (Actual) then 766 return Entity (Actual); 767 768 else 769 Var := Make_Defining_Identifier (Loc, New_Internal_Name ('T')); 770 771 N_Node := 772 Make_Object_Renaming_Declaration (Loc, 773 Defining_Identifier => Var, 774 Subtype_Mark => 775 New_Occurrence_Of (Etype (Actual), Loc), 776 Name => Relocate_Node (Actual)); 777 778 Insert_Action (N, N_Node); 779 return Var; 780 end if; 781 end Make_Var; 782 783 ------------------------- 784 -- Reset_Packed_Prefix -- 785 ------------------------- 786 787 procedure Reset_Packed_Prefix is 788 Pfx : Node_Id := Actual; 789 790 begin 791 loop 792 Set_Analyzed (Pfx, False); 793 exit when Nkind (Pfx) /= N_Selected_Component 794 and then Nkind (Pfx) /= N_Indexed_Component; 795 Pfx := Prefix (Pfx); 796 end loop; 797 end Reset_Packed_Prefix; 798 799 -- Start of processing for Expand_Actuals 800 801 begin 802 Formal := First_Formal (Subp); 803 Actual := First_Actual (N); 804 805 Post_Call := New_List; 806 807 while Present (Formal) loop 808 E_Formal := Etype (Formal); 809 810 if Is_Scalar_Type (E_Formal) 811 or else Nkind (Actual) = N_Slice 812 then 813 Check_Fortran_Logical; 814 815 -- RM 6.4.1 (11) 816 817 elsif Ekind (Formal) /= E_Out_Parameter then 818 819 -- The unusual case of the current instance of a protected type 820 -- requires special handling. This can only occur in the context 821 -- of a call within the body of a protected operation. 822 823 if Is_Entity_Name (Actual) 824 and then Ekind (Entity (Actual)) = E_Protected_Type 825 and then In_Open_Scopes (Entity (Actual)) 826 then 827 if Scope (Subp) /= Entity (Actual) then 828 Error_Msg_N ("operation outside protected type may not " 829 & "call back its protected operations?", Actual); 830 end if; 831 832 Rewrite (Actual, 833 Expand_Protected_Object_Reference (N, Entity (Actual))); 834 end if; 835 836 Apply_Constraint_Check (Actual, E_Formal); 837 838 -- Out parameter case. No constraint checks on access type 839 -- RM 6.4.1 (13) 840 841 elsif Is_Access_Type (E_Formal) then 842 null; 843 844 -- RM 6.4.1 (14) 845 846 elsif Has_Discriminants (Base_Type (E_Formal)) 847 or else Has_Non_Null_Base_Init_Proc (E_Formal) 848 then 849 Apply_Constraint_Check (Actual, E_Formal); 850 851 -- RM 6.4.1 (15) 852 853 else 854 Apply_Constraint_Check (Actual, Base_Type (E_Formal)); 855 end if; 856 857 -- Processing for IN-OUT and OUT parameters 858 859 if Ekind (Formal) /= E_In_Parameter then 860 861 -- For type conversions of arrays, apply length/range checks 862 863 if Is_Array_Type (E_Formal) 864 and then Nkind (Actual) = N_Type_Conversion 865 then 866 if Is_Constrained (E_Formal) then 867 Apply_Length_Check (Expression (Actual), E_Formal); 868 else 869 Apply_Range_Check (Expression (Actual), E_Formal); 870 end if; 871 end if; 872 873 -- If argument is a type conversion for a type that is passed 874 -- by copy, then we must pass the parameter by copy. 875 876 if Nkind (Actual) = N_Type_Conversion 877 and then 878 (Is_Numeric_Type (E_Formal) 879 or else Is_Access_Type (E_Formal) 880 or else Is_Enumeration_Type (E_Formal) 881 or else Is_Bit_Packed_Array (Etype (Formal)) 882 or else Is_Bit_Packed_Array (Etype (Expression (Actual))) 883 884 -- Also pass by copy if change of representation 885 886 or else not Same_Representation 887 (Etype (Formal), 888 Etype (Expression (Actual)))) 889 then 890 Add_Call_By_Copy_Code; 891 892 -- References to components of bit packed arrays are expanded 893 -- at this point, rather than at the point of analysis of the 894 -- actuals, to handle the expansion of the assignment to 895 -- [in] out parameters. 896 897 elsif Is_Ref_To_Bit_Packed_Array (Actual) then 898 Add_Packed_Call_By_Copy_Code; 899 900 -- References to slices of bit packed arrays are expanded 901 902 elsif Is_Ref_To_Bit_Packed_Slice (Actual) then 903 Add_Call_By_Copy_Code; 904 905 -- References to possibly unaligned slices of arrays are expanded 906 907 elsif Is_Possibly_Unaligned_Slice (Actual) then 908 Add_Call_By_Copy_Code; 909 910 -- Deal with access types where the actual subtpe and the 911 -- formal subtype are not the same, requiring a check. 912 913 -- It is necessary to exclude tagged types because of "downward 914 -- conversion" errors and a strange assertion error in namet 915 -- from gnatf in bug 1215-001 ??? 916 917 elsif Is_Access_Type (E_Formal) 918 and then not Same_Type (E_Formal, Etype (Actual)) 919 and then not Is_Tagged_Type (Designated_Type (E_Formal)) 920 then 921 Add_Call_By_Copy_Code; 922 923 elsif Is_Entity_Name (Actual) 924 and then Treat_As_Volatile (Entity (Actual)) 925 and then not Is_Scalar_Type (Etype (Entity (Actual))) 926 and then not Treat_As_Volatile (E_Formal) 927 then 928 Add_Call_By_Copy_Code; 929 930 elsif Nkind (Actual) = N_Indexed_Component 931 and then Is_Entity_Name (Prefix (Actual)) 932 and then Has_Volatile_Components (Entity (Prefix (Actual))) 933 then 934 Add_Call_By_Copy_Code; 935 end if; 936 937 -- Processing for IN parameters 938 939 else 940 -- For IN parameters is in the packed array case, we expand an 941 -- indexed component (the circuit in Exp_Ch4 deliberately left 942 -- indexed components appearing as actuals untouched, so that 943 -- the special processing above for the OUT and IN OUT cases 944 -- could be performed. We could make the test in Exp_Ch4 more 945 -- complex and have it detect the parameter mode, but it is 946 -- easier simply to handle all cases here. 947 948 if Nkind (Actual) = N_Indexed_Component 949 and then Is_Packed (Etype (Prefix (Actual))) 950 then 951 Reset_Packed_Prefix; 952 Expand_Packed_Element_Reference (Actual); 953 954 -- If we have a reference to a bit packed array, we copy it, 955 -- since the actual must be byte aligned. 956 957 -- Is this really necessary in all cases??? 958 959 elsif Is_Ref_To_Bit_Packed_Array (Actual) then 960 Add_Packed_Call_By_Copy_Code; 961 962 -- Similarly, we have to expand slices of packed arrays here 963 -- because the result must be byte aligned. 964 965 elsif Is_Ref_To_Bit_Packed_Slice (Actual) then 966 Add_Call_By_Copy_Code; 967 968 -- Only processing remaining is to pass by copy if this is a 969 -- reference to a possibly unaligned slice, since the caller 970 -- expects an appropriately aligned argument. 971 972 elsif Is_Possibly_Unaligned_Slice (Actual) then 973 Add_Call_By_Copy_Code; 974 end if; 975 end if; 976 977 Next_Formal (Formal); 978 Next_Actual (Actual); 979 end loop; 980 981 -- Find right place to put post call stuff if it is present 982 983 if not Is_Empty_List (Post_Call) then 984 985 -- If call is not a list member, it must be the triggering 986 -- statement of a triggering alternative or an entry call 987 -- alternative, and we can add the post call stuff to the 988 -- corresponding statement list. 989 990 if not Is_List_Member (N) then 991 declare 992 P : constant Node_Id := Parent (N); 993 994 begin 995 pragma Assert (Nkind (P) = N_Triggering_Alternative 996 or else Nkind (P) = N_Entry_Call_Alternative); 997 998 if Is_Non_Empty_List (Statements (P)) then 999 Insert_List_Before_And_Analyze 1000 (First (Statements (P)), Post_Call); 1001 else 1002 Set_Statements (P, Post_Call); 1003 end if; 1004 end; 1005 1006 -- Otherwise, normal case where N is in a statement sequence, 1007 -- just put the post-call stuff after the call statement. 1008 1009 else 1010 Insert_Actions_After (N, Post_Call); 1011 end if; 1012 end if; 1013 1014 -- The call node itself is re-analyzed in Expand_Call. 1015 1016 end Expand_Actuals; 1017 1018 ----------------- 1019 -- Expand_Call -- 1020 ----------------- 1021 1022 -- This procedure handles expansion of function calls and procedure call 1023 -- statements (i.e. it serves as the body for Expand_N_Function_Call and 1024 -- Expand_N_Procedure_Call_Statement. Processing for calls includes: 1025 1026 -- Replace call to Raise_Exception by Raise_Exception always if possible 1027 -- Provide values of actuals for all formals in Extra_Formals list 1028 -- Replace "call" to enumeration literal function by literal itself 1029 -- Rewrite call to predefined operator as operator 1030 -- Replace actuals to in-out parameters that are numeric conversions, 1031 -- with explicit assignment to temporaries before and after the call. 1032 -- Remove optional actuals if First_Optional_Parameter specified. 1033 1034 -- Note that the list of actuals has been filled with default expressions 1035 -- during semantic analysis of the call. Only the extra actuals required 1036 -- for the 'Constrained attribute and for accessibility checks are added 1037 -- at this point. 1038 1039 procedure Expand_Call (N : Node_Id) is 1040 Loc : constant Source_Ptr := Sloc (N); 1041 Remote : constant Boolean := Is_Remote_Call (N); 1042 Subp : Entity_Id; 1043 Orig_Subp : Entity_Id := Empty; 1044 Parent_Subp : Entity_Id; 1045 Parent_Formal : Entity_Id; 1046 Actual : Node_Id; 1047 Formal : Entity_Id; 1048 Prev : Node_Id := Empty; 1049 Prev_Orig : Node_Id; 1050 Scop : Entity_Id; 1051 Extra_Actuals : List_Id := No_List; 1052 Cond : Node_Id; 1053 1054 procedure Add_Actual_Parameter (Insert_Param : Node_Id); 1055 -- Adds one entry to the end of the actual parameter list. Used for 1056 -- default parameters and for extra actuals (for Extra_Formals). 1057 -- The argument is an N_Parameter_Association node. 1058 1059 procedure Add_Extra_Actual (Expr : Node_Id; EF : Entity_Id); 1060 -- Adds an extra actual to the list of extra actuals. Expr 1061 -- is the expression for the value of the actual, EF is the 1062 -- entity for the extra formal. 1063 1064 function Inherited_From_Formal (S : Entity_Id) return Entity_Id; 1065 -- Within an instance, a type derived from a non-tagged formal derived 1066 -- type inherits from the original parent, not from the actual. This is 1067 -- tested in 4723-003. The current derivation mechanism has the derived 1068 -- type inherit from the actual, which is only correct outside of the 1069 -- instance. If the subprogram is inherited, we test for this particular 1070 -- case through a convoluted tree traversal before setting the proper 1071 -- subprogram to be called. 1072 1073 -------------------------- 1074 -- Add_Actual_Parameter -- 1075 -------------------------- 1076 1077 procedure Add_Actual_Parameter (Insert_Param : Node_Id) is 1078 Actual_Expr : constant Node_Id := 1079 Explicit_Actual_Parameter (Insert_Param); 1080 1081 begin 1082 -- Case of insertion is first named actual 1083 1084 if No (Prev) or else 1085 Nkind (Parent (Prev)) /= N_Parameter_Association 1086 then 1087 Set_Next_Named_Actual (Insert_Param, First_Named_Actual (N)); 1088 Set_First_Named_Actual (N, Actual_Expr); 1089 1090 if No (Prev) then 1091 if not Present (Parameter_Associations (N)) then 1092 Set_Parameter_Associations (N, New_List); 1093 Append (Insert_Param, Parameter_Associations (N)); 1094 end if; 1095 else 1096 Insert_After (Prev, Insert_Param); 1097 end if; 1098 1099 -- Case of insertion is not first named actual 1100 1101 else 1102 Set_Next_Named_Actual 1103 (Insert_Param, Next_Named_Actual (Parent (Prev))); 1104 Set_Next_Named_Actual (Parent (Prev), Actual_Expr); 1105 Append (Insert_Param, Parameter_Associations (N)); 1106 end if; 1107 1108 Prev := Actual_Expr; 1109 end Add_Actual_Parameter; 1110 1111 ---------------------- 1112 -- Add_Extra_Actual -- 1113 ---------------------- 1114 1115 procedure Add_Extra_Actual (Expr : Node_Id; EF : Entity_Id) is 1116 Loc : constant Source_Ptr := Sloc (Expr); 1117 1118 begin 1119 if Extra_Actuals = No_List then 1120 Extra_Actuals := New_List; 1121 Set_Parent (Extra_Actuals, N); 1122 end if; 1123 1124 Append_To (Extra_Actuals, 1125 Make_Parameter_Association (Loc, 1126 Explicit_Actual_Parameter => Expr, 1127 Selector_Name => 1128 Make_Identifier (Loc, Chars (EF)))); 1129 1130 Analyze_And_Resolve (Expr, Etype (EF)); 1131 end Add_Extra_Actual; 1132 1133 --------------------------- 1134 -- Inherited_From_Formal -- 1135 --------------------------- 1136 1137 function Inherited_From_Formal (S : Entity_Id) return Entity_Id is 1138 Par : Entity_Id; 1139 Gen_Par : Entity_Id; 1140 Gen_Prim : Elist_Id; 1141 Elmt : Elmt_Id; 1142 Indic : Node_Id; 1143 1144 begin 1145 -- If the operation is inherited, it is attached to the corresponding 1146 -- type derivation. If the parent in the derivation is a generic 1147 -- actual, it is a subtype of the actual, and we have to recover the 1148 -- original derived type declaration to find the proper parent. 1149 1150 if Nkind (Parent (S)) /= N_Full_Type_Declaration 1151 or else not Is_Derived_Type (Defining_Identifier (Parent (S))) 1152 or else Nkind (Type_Definition (Original_Node (Parent (S)))) 1153 /= N_Derived_Type_Definition 1154 or else not In_Instance 1155 then 1156 return Empty; 1157 1158 else 1159 Indic := 1160 (Subtype_Indication 1161 (Type_Definition (Original_Node (Parent (S))))); 1162 1163 if Nkind (Indic) = N_Subtype_Indication then 1164 Par := Entity (Subtype_Mark (Indic)); 1165 else 1166 Par := Entity (Indic); 1167 end if; 1168 end if; 1169 1170 if not Is_Generic_Actual_Type (Par) 1171 or else Is_Tagged_Type (Par) 1172 or else Nkind (Parent (Par)) /= N_Subtype_Declaration 1173 or else not In_Open_Scopes (Scope (Par)) 1174 then 1175 return Empty; 1176 1177 else 1178 Gen_Par := Generic_Parent_Type (Parent (Par)); 1179 end if; 1180 1181 -- If the generic parent type is still the generic type, this 1182 -- is a private formal, not a derived formal, and there are no 1183 -- operations inherited from the formal. 1184 1185 if Nkind (Parent (Gen_Par)) = N_Formal_Type_Declaration then 1186 return Empty; 1187 end if; 1188 1189 Gen_Prim := Collect_Primitive_Operations (Gen_Par); 1190 Elmt := First_Elmt (Gen_Prim); 1191 1192 while Present (Elmt) loop 1193 if Chars (Node (Elmt)) = Chars (S) then 1194 declare 1195 F1 : Entity_Id; 1196 F2 : Entity_Id; 1197 begin 1198 1199 F1 := First_Formal (S); 1200 F2 := First_Formal (Node (Elmt)); 1201 1202 while Present (F1) 1203 and then Present (F2) 1204 loop 1205 1206 if Etype (F1) = Etype (F2) 1207 or else Etype (F2) = Gen_Par 1208 then 1209 Next_Formal (F1); 1210 Next_Formal (F2); 1211 else 1212 Next_Elmt (Elmt); 1213 exit; -- not the right subprogram 1214 end if; 1215 1216 return Node (Elmt); 1217 end loop; 1218 end; 1219 1220 else 1221 Next_Elmt (Elmt); 1222 end if; 1223 end loop; 1224 1225 raise Program_Error; 1226 end Inherited_From_Formal; 1227 1228 -- Start of processing for Expand_Call 1229 1230 begin 1231 -- Ignore if previous error 1232 1233 if Nkind (N) in N_Has_Etype and then Etype (N) = Any_Type then 1234 return; 1235 end if; 1236 1237 -- Call using access to subprogram with explicit dereference 1238 1239 if Nkind (Name (N)) = N_Explicit_Dereference then 1240 Subp := Etype (Name (N)); 1241 Parent_Subp := Empty; 1242 1243 -- Case of call to simple entry, where the Name is a selected component 1244 -- whose prefix is the task, and whose selector name is the entry name 1245 1246 elsif Nkind (Name (N)) = N_Selected_Component then 1247 Subp := Entity (Selector_Name (Name (N))); 1248 Parent_Subp := Empty; 1249 1250 -- Case of call to member of entry family, where Name is an indexed 1251 -- component, with the prefix being a selected component giving the 1252 -- task and entry family name, and the index being the entry index. 1253 1254 elsif Nkind (Name (N)) = N_Indexed_Component then 1255 Subp := Entity (Selector_Name (Prefix (Name (N)))); 1256 Parent_Subp := Empty; 1257 1258 -- Normal case 1259 1260 else 1261 Subp := Entity (Name (N)); 1262 Parent_Subp := Alias (Subp); 1263 1264 -- Replace call to Raise_Exception by call to Raise_Exception_Always 1265 -- if we can tell that the first parameter cannot possibly be null. 1266 -- This helps optimization and also generation of warnings. 1267 1268 if not Restrictions (No_Exception_Handlers) 1269 and then Is_RTE (Subp, RE_Raise_Exception) 1270 then 1271 declare 1272 FA : constant Node_Id := Original_Node (First_Actual (N)); 1273 1274 begin 1275 -- The case we catch is where the first argument is obtained 1276 -- using the Identity attribute (which must always be non-null) 1277 1278 if Nkind (FA) = N_Attribute_Reference 1279 and then Attribute_Name (FA) = Name_Identity 1280 then 1281 Subp := RTE (RE_Raise_Exception_Always); 1282 Set_Entity (Name (N), Subp); 1283 end if; 1284 end; 1285 end if; 1286 1287 if Ekind (Subp) = E_Entry then 1288 Parent_Subp := Empty; 1289 end if; 1290 end if; 1291 1292 -- First step, compute extra actuals, corresponding to any 1293 -- Extra_Formals present. Note that we do not access Extra_Formals 1294 -- directly, instead we simply note the presence of the extra 1295 -- formals as we process the regular formals and collect the 1296 -- corresponding actuals in Extra_Actuals. 1297 1298 -- We also generate any required range checks for actuals as we go 1299 -- through the loop, since this is a convenient place to do this. 1300 1301 Formal := First_Formal (Subp); 1302 Actual := First_Actual (N); 1303 while Present (Formal) loop 1304 1305 -- Generate range check if required (not activated yet ???) 1306 1307-- if Do_Range_Check (Actual) then 1308-- Set_Do_Range_Check (Actual, False); 1309-- Generate_Range_Check 1310-- (Actual, Etype (Formal), CE_Range_Check_Failed); 1311-- end if; 1312 1313 -- Prepare to examine current entry 1314 1315 Prev := Actual; 1316 Prev_Orig := Original_Node (Prev); 1317 1318 -- Create possible extra actual for constrained case. Usually, 1319 -- the extra actual is of the form actual'constrained, but since 1320 -- this attribute is only available for unconstrained records, 1321 -- TRUE is expanded if the type of the formal happens to be 1322 -- constrained (for instance when this procedure is inherited 1323 -- from an unconstrained record to a constrained one) or if the 1324 -- actual has no discriminant (its type is constrained). An 1325 -- exception to this is the case of a private type without 1326 -- discriminants. In this case we pass FALSE because the 1327 -- object has underlying discriminants with defaults. 1328 1329 if Present (Extra_Constrained (Formal)) then 1330 if Ekind (Etype (Prev)) in Private_Kind 1331 and then not Has_Discriminants (Base_Type (Etype (Prev))) 1332 then 1333 Add_Extra_Actual ( 1334 New_Occurrence_Of (Standard_False, Loc), 1335 Extra_Constrained (Formal)); 1336 1337 elsif Is_Constrained (Etype (Formal)) 1338 or else not Has_Discriminants (Etype (Prev)) 1339 then 1340 Add_Extra_Actual ( 1341 New_Occurrence_Of (Standard_True, Loc), 1342 Extra_Constrained (Formal)); 1343 1344 else 1345 -- If the actual is a type conversion, then the constrained 1346 -- test applies to the actual, not the target type. 1347 1348 declare 1349 Act_Prev : Node_Id := Prev; 1350 1351 begin 1352 -- Test for unchecked conversions as well, which can 1353 -- occur as out parameter actuals on calls to stream 1354 -- procedures. 1355 1356 while Nkind (Act_Prev) = N_Type_Conversion 1357 or else Nkind (Act_Prev) = N_Unchecked_Type_Conversion 1358 loop 1359 Act_Prev := Expression (Act_Prev); 1360 end loop; 1361 1362 Add_Extra_Actual ( 1363 Make_Attribute_Reference (Sloc (Prev), 1364 Prefix => 1365 Duplicate_Subexpr_No_Checks 1366 (Act_Prev, Name_Req => True), 1367 Attribute_Name => Name_Constrained), 1368 Extra_Constrained (Formal)); 1369 end; 1370 end if; 1371 end if; 1372 1373 -- Create possible extra actual for accessibility level 1374 1375 if Present (Extra_Accessibility (Formal)) then 1376 if Is_Entity_Name (Prev_Orig) then 1377 1378 -- When passing an access parameter as the actual to another 1379 -- access parameter we need to pass along the actual's own 1380 -- associated access level parameter. This is done is we are 1381 -- in the scope of the formal access parameter (if this is an 1382 -- inlined body the extra formal is irrelevant). 1383 1384 if Ekind (Entity (Prev_Orig)) in Formal_Kind 1385 and then Ekind (Etype (Prev_Orig)) = E_Anonymous_Access_Type 1386 and then In_Open_Scopes (Scope (Entity (Prev_Orig))) 1387 then 1388 declare 1389 Parm_Ent : constant Entity_Id := Param_Entity (Prev_Orig); 1390 1391 begin 1392 pragma Assert (Present (Parm_Ent)); 1393 1394 if Present (Extra_Accessibility (Parm_Ent)) then 1395 Add_Extra_Actual ( 1396 New_Occurrence_Of 1397 (Extra_Accessibility (Parm_Ent), Loc), 1398 Extra_Accessibility (Formal)); 1399 1400 -- If the actual access parameter does not have an 1401 -- associated extra formal providing its scope level, 1402 -- then treat the actual as having library-level 1403 -- accessibility. 1404 1405 else 1406 Add_Extra_Actual ( 1407 Make_Integer_Literal (Loc, 1408 Intval => Scope_Depth (Standard_Standard)), 1409 Extra_Accessibility (Formal)); 1410 end if; 1411 end; 1412 1413 -- The actual is a normal access value, so just pass the 1414 -- level of the actual's access type. 1415 1416 else 1417 Add_Extra_Actual ( 1418 Make_Integer_Literal (Loc, 1419 Intval => Type_Access_Level (Etype (Prev_Orig))), 1420 Extra_Accessibility (Formal)); 1421 end if; 1422 1423 else 1424 case Nkind (Prev_Orig) is 1425 1426 when N_Attribute_Reference => 1427 1428 case Get_Attribute_Id (Attribute_Name (Prev_Orig)) is 1429 1430 -- For X'Access, pass on the level of the prefix X 1431 1432 when Attribute_Access => 1433 Add_Extra_Actual ( 1434 Make_Integer_Literal (Loc, 1435 Intval => 1436 Object_Access_Level (Prefix (Prev_Orig))), 1437 Extra_Accessibility (Formal)); 1438 1439 -- Treat the unchecked attributes as library-level 1440 1441 when Attribute_Unchecked_Access | 1442 Attribute_Unrestricted_Access => 1443 Add_Extra_Actual ( 1444 Make_Integer_Literal (Loc, 1445 Intval => Scope_Depth (Standard_Standard)), 1446 Extra_Accessibility (Formal)); 1447 1448 -- No other cases of attributes returning access 1449 -- values that can be passed to access parameters 1450 1451 when others => 1452 raise Program_Error; 1453 1454 end case; 1455 1456 -- For allocators we pass the level of the execution of 1457 -- the called subprogram, which is one greater than the 1458 -- current scope level. 1459 1460 when N_Allocator => 1461 Add_Extra_Actual ( 1462 Make_Integer_Literal (Loc, 1463 Scope_Depth (Current_Scope) + 1), 1464 Extra_Accessibility (Formal)); 1465 1466 -- For other cases we simply pass the level of the 1467 -- actual's access type. 1468 1469 when others => 1470 Add_Extra_Actual ( 1471 Make_Integer_Literal (Loc, 1472 Intval => Type_Access_Level (Etype (Prev_Orig))), 1473 Extra_Accessibility (Formal)); 1474 1475 end case; 1476 end if; 1477 end if; 1478 1479 -- Perform the check of 4.6(49) that prevents a null value 1480 -- from being passed as an actual to an access parameter. 1481 -- Note that the check is elided in the common cases of 1482 -- passing an access attribute or access parameter as an 1483 -- actual. Also, we currently don't enforce this check for 1484 -- expander-generated actuals and when -gnatdj is set. 1485 1486 if Ekind (Etype (Formal)) /= E_Anonymous_Access_Type 1487 or else Access_Checks_Suppressed (Subp) 1488 then 1489 null; 1490 1491 elsif Debug_Flag_J then 1492 null; 1493 1494 elsif not Comes_From_Source (Prev) then 1495 null; 1496 1497 elsif Is_Entity_Name (Prev) 1498 and then Ekind (Etype (Prev)) = E_Anonymous_Access_Type 1499 then 1500 null; 1501 1502 elsif Nkind (Prev) = N_Allocator 1503 or else Nkind (Prev) = N_Attribute_Reference 1504 then 1505 null; 1506 1507 -- Suppress null checks when passing to access parameters 1508 -- of Java subprograms. (Should this be done for other 1509 -- foreign conventions as well ???) 1510 1511 elsif Convention (Subp) = Convention_Java then 1512 null; 1513 1514 else 1515 Cond := 1516 Make_Op_Eq (Loc, 1517 Left_Opnd => Duplicate_Subexpr_No_Checks (Prev), 1518 Right_Opnd => Make_Null (Loc)); 1519 Insert_Action (Prev, 1520 Make_Raise_Constraint_Error (Loc, 1521 Condition => Cond, 1522 Reason => CE_Access_Parameter_Is_Null)); 1523 end if; 1524 1525 -- Perform appropriate validity checks on parameters that 1526 -- are entities. 1527 1528 if Validity_Checks_On then 1529 if Ekind (Formal) = E_In_Parameter 1530 and then Validity_Check_In_Params 1531 then 1532 -- If the actual is an indexed component of a packed 1533 -- type, it has not been expanded yet. It will be 1534 -- copied in the validity code that follows, and has 1535 -- to be expanded appropriately, so reanalyze it. 1536 1537 if Nkind (Actual) = N_Indexed_Component then 1538 Set_Analyzed (Actual, False); 1539 end if; 1540 1541 Ensure_Valid (Actual); 1542 1543 elsif Ekind (Formal) = E_In_Out_Parameter 1544 and then Validity_Check_In_Out_Params 1545 then 1546 Ensure_Valid (Actual); 1547 end if; 1548 end if; 1549 1550 -- For IN OUT and OUT parameters, ensure that subscripts are valid 1551 -- since this is a left side reference. We only do this for calls 1552 -- from the source program since we assume that compiler generated 1553 -- calls explicitly generate any required checks. We also need it 1554 -- only if we are doing standard validity checks, since clearly it 1555 -- is not needed if validity checks are off, and in subscript 1556 -- validity checking mode, all indexed components are checked with 1557 -- a call directly from Expand_N_Indexed_Component. 1558 1559 if Comes_From_Source (N) 1560 and then Ekind (Formal) /= E_In_Parameter 1561 and then Validity_Checks_On 1562 and then Validity_Check_Default 1563 and then not Validity_Check_Subscripts 1564 then 1565 Check_Valid_Lvalue_Subscripts (Actual); 1566 end if; 1567 1568 -- Mark any scalar OUT parameter that is a simple variable 1569 -- as no longer known to be valid (unless the type is always 1570 -- valid). This reflects the fact that if an OUT parameter 1571 -- is never set in a procedure, then it can become invalid 1572 -- on return from the procedure. 1573 1574 if Ekind (Formal) = E_Out_Parameter 1575 and then Is_Entity_Name (Actual) 1576 and then Ekind (Entity (Actual)) = E_Variable 1577 and then not Is_Known_Valid (Etype (Actual)) 1578 then 1579 Set_Is_Known_Valid (Entity (Actual), False); 1580 end if; 1581 1582 -- For an OUT or IN OUT parameter of an access type, if the 1583 -- actual is an entity, then it is no longer known to be non-null. 1584 1585 if Ekind (Formal) /= E_In_Parameter 1586 and then Is_Entity_Name (Actual) 1587 and then Is_Access_Type (Etype (Actual)) 1588 then 1589 Set_Is_Known_Non_Null (Entity (Actual), False); 1590 end if; 1591 1592 -- If the formal is class wide and the actual is an aggregate, force 1593 -- evaluation so that the back end who does not know about class-wide 1594 -- type, does not generate a temporary of the wrong size. 1595 1596 if not Is_Class_Wide_Type (Etype (Formal)) then 1597 null; 1598 1599 elsif Nkind (Actual) = N_Aggregate 1600 or else (Nkind (Actual) = N_Qualified_Expression 1601 and then Nkind (Expression (Actual)) = N_Aggregate) 1602 then 1603 Force_Evaluation (Actual); 1604 end if; 1605 1606 -- In a remote call, if the formal is of a class-wide type, check 1607 -- that the actual meets the requirements described in E.4(18). 1608 1609 if Remote 1610 and then Is_Class_Wide_Type (Etype (Formal)) 1611 then 1612 Insert_Action (Actual, 1613 Make_Implicit_If_Statement (N, 1614 Condition => 1615 Make_Op_Not (Loc, 1616 Get_Remotely_Callable 1617 (Duplicate_Subexpr_Move_Checks (Actual))), 1618 Then_Statements => New_List ( 1619 Make_Procedure_Call_Statement (Loc, 1620 New_Occurrence_Of (RTE 1621 (RE_Raise_Program_Error_For_E_4_18), Loc))))); 1622 end if; 1623 1624 Next_Actual (Actual); 1625 Next_Formal (Formal); 1626 end loop; 1627 1628 -- If we are expanding a rhs of an assignement we need to check if 1629 -- tag propagation is needed. This code belongs theorically in Analyze 1630 -- Assignment but has to be done earlier (bottom-up) because the 1631 -- assignment might be transformed into a declaration for an uncons- 1632 -- trained value, if the expression is classwide. 1633 1634 if Nkind (N) = N_Function_Call 1635 and then Is_Tag_Indeterminate (N) 1636 and then Is_Entity_Name (Name (N)) 1637 then 1638 declare 1639 Ass : Node_Id := Empty; 1640 1641 begin 1642 if Nkind (Parent (N)) = N_Assignment_Statement then 1643 Ass := Parent (N); 1644 1645 elsif Nkind (Parent (N)) = N_Qualified_Expression 1646 and then Nkind (Parent (Parent (N))) = N_Assignment_Statement 1647 then 1648 Ass := Parent (Parent (N)); 1649 end if; 1650 1651 if Present (Ass) 1652 and then Is_Class_Wide_Type (Etype (Name (Ass))) 1653 then 1654 if Etype (N) /= Root_Type (Etype (Name (Ass))) then 1655 Error_Msg_NE 1656 ("tag-indeterminate expression must have type&" 1657 & "('R'M 5.2 (6))", N, Root_Type (Etype (Name (Ass)))); 1658 else 1659 Propagate_Tag (Name (Ass), N); 1660 end if; 1661 1662 -- The call will be rewritten as a dispatching call, and 1663 -- expanded as such. 1664 1665 return; 1666 end if; 1667 end; 1668 end if; 1669 1670 -- Deals with Dispatch_Call if we still have a call, before expanding 1671 -- extra actuals since this will be done on the re-analysis of the 1672 -- dispatching call. Note that we do not try to shorten the actual 1673 -- list for a dispatching call, it would not make sense to do so. 1674 -- Expansion of dispatching calls is suppressed when Java_VM, because 1675 -- the JVM back end directly handles the generation of dispatching 1676 -- calls and would have to undo any expansion to an indirect call. 1677 1678 if (Nkind (N) = N_Function_Call 1679 or else Nkind (N) = N_Procedure_Call_Statement) 1680 and then Present (Controlling_Argument (N)) 1681 and then not Java_VM 1682 then 1683 Expand_Dispatch_Call (N); 1684 1685 -- The following return is worrisome. Is it really OK to 1686 -- skip all remaining processing in this procedure ??? 1687 1688 return; 1689 1690 -- Similarly, expand calls to RCI subprograms on which pragma 1691 -- All_Calls_Remote applies. The rewriting will be reanalyzed 1692 -- later. Do this only when the call comes from source since we do 1693 -- not want such a rewritting to occur in expanded code. 1694 1695 elsif Is_All_Remote_Call (N) then 1696 Expand_All_Calls_Remote_Subprogram_Call (N); 1697 1698 -- Similarly, do not add extra actuals for an entry call whose entity 1699 -- is a protected procedure, or for an internal protected subprogram 1700 -- call, because it will be rewritten as a protected subprogram call 1701 -- and reanalyzed (see Expand_Protected_Subprogram_Call). 1702 1703 elsif Is_Protected_Type (Scope (Subp)) 1704 and then (Ekind (Subp) = E_Procedure 1705 or else Ekind (Subp) = E_Function) 1706 then 1707 null; 1708 1709 -- During that loop we gathered the extra actuals (the ones that 1710 -- correspond to Extra_Formals), so now they can be appended. 1711 1712 else 1713 while Is_Non_Empty_List (Extra_Actuals) loop 1714 Add_Actual_Parameter (Remove_Head (Extra_Actuals)); 1715 end loop; 1716 end if; 1717 1718 if Ekind (Subp) = E_Procedure 1719 or else (Ekind (Subp) = E_Subprogram_Type 1720 and then Etype (Subp) = Standard_Void_Type) 1721 or else Is_Entry (Subp) 1722 then 1723 Expand_Actuals (N, Subp); 1724 end if; 1725 1726 -- If the subprogram is a renaming, or if it is inherited, replace it 1727 -- in the call with the name of the actual subprogram being called. 1728 -- If this is a dispatching call, the run-time decides what to call. 1729 -- The Alias attribute does not apply to entries. 1730 1731 if Nkind (N) /= N_Entry_Call_Statement 1732 and then No (Controlling_Argument (N)) 1733 and then Present (Parent_Subp) 1734 then 1735 if Present (Inherited_From_Formal (Subp)) then 1736 Parent_Subp := Inherited_From_Formal (Subp); 1737 else 1738 while Present (Alias (Parent_Subp)) loop 1739 Parent_Subp := Alias (Parent_Subp); 1740 end loop; 1741 end if; 1742 1743 Set_Entity (Name (N), Parent_Subp); 1744 1745 if Is_Abstract (Parent_Subp) 1746 and then not In_Instance 1747 then 1748 Error_Msg_NE 1749 ("cannot call abstract subprogram &!", Name (N), Parent_Subp); 1750 end if; 1751 1752 -- Add an explicit conversion for parameter of the derived type. 1753 -- This is only done for scalar and access in-parameters. Others 1754 -- have been expanded in expand_actuals. 1755 1756 Formal := First_Formal (Subp); 1757 Parent_Formal := First_Formal (Parent_Subp); 1758 Actual := First_Actual (N); 1759 1760 -- It is not clear that conversion is needed for intrinsic 1761 -- subprograms, but it certainly is for those that are user- 1762 -- defined, and that can be inherited on derivation, namely 1763 -- unchecked conversion and deallocation. 1764 -- General case needs study ??? 1765 1766 if not Is_Intrinsic_Subprogram (Parent_Subp) 1767 or else Is_Generic_Instance (Parent_Subp) 1768 then 1769 while Present (Formal) loop 1770 1771 if Etype (Formal) /= Etype (Parent_Formal) 1772 and then Is_Scalar_Type (Etype (Formal)) 1773 and then Ekind (Formal) = E_In_Parameter 1774 and then not Raises_Constraint_Error (Actual) 1775 then 1776 Rewrite (Actual, 1777 OK_Convert_To (Etype (Parent_Formal), 1778 Relocate_Node (Actual))); 1779 1780 Analyze (Actual); 1781 Resolve (Actual, Etype (Parent_Formal)); 1782 Enable_Range_Check (Actual); 1783 1784 elsif Is_Access_Type (Etype (Formal)) 1785 and then Base_Type (Etype (Parent_Formal)) 1786 /= Base_Type (Etype (Actual)) 1787 then 1788 if Ekind (Formal) /= E_In_Parameter then 1789 Rewrite (Actual, 1790 Convert_To (Etype (Parent_Formal), 1791 Relocate_Node (Actual))); 1792 1793 Analyze (Actual); 1794 Resolve (Actual, Etype (Parent_Formal)); 1795 1796 elsif 1797 Ekind (Etype (Parent_Formal)) = E_Anonymous_Access_Type 1798 and then Designated_Type (Etype (Parent_Formal)) 1799 /= 1800 Designated_Type (Etype (Actual)) 1801 and then not Is_Controlling_Formal (Formal) 1802 then 1803 -- This unchecked conversion is not necessary unless 1804 -- inlining is enabled, because in that case the type 1805 -- mismatch may become visible in the body about to be 1806 -- inlined. 1807 1808 Rewrite (Actual, 1809 Unchecked_Convert_To (Etype (Parent_Formal), 1810 Relocate_Node (Actual))); 1811 1812 Analyze (Actual); 1813 Resolve (Actual, Etype (Parent_Formal)); 1814 end if; 1815 end if; 1816 1817 Next_Formal (Formal); 1818 Next_Formal (Parent_Formal); 1819 Next_Actual (Actual); 1820 end loop; 1821 end if; 1822 1823 Orig_Subp := Subp; 1824 Subp := Parent_Subp; 1825 end if; 1826 1827 if Is_RTE (Subp, RE_Abort_Task) then 1828 Check_Restriction (No_Abort_Statements, N); 1829 end if; 1830 1831 -- Some more special cases for cases other than explicit dereference 1832 1833 if Nkind (Name (N)) /= N_Explicit_Dereference then 1834 1835 -- Calls to an enumeration literal are replaced by the literal 1836 -- This case occurs only when we have a call to a function that 1837 -- is a renaming of an enumeration literal. The normal case of 1838 -- a direct reference to an enumeration literal has already been 1839 -- been dealt with by Resolve_Call. If the function is itself 1840 -- inherited (see 7423-001) the literal of the parent type must 1841 -- be explicitly converted to the return type of the function. 1842 1843 if Ekind (Subp) = E_Enumeration_Literal then 1844 if Base_Type (Etype (Subp)) /= Base_Type (Etype (N)) then 1845 Rewrite 1846 (N, Convert_To (Etype (N), New_Occurrence_Of (Subp, Loc))); 1847 else 1848 Rewrite (N, New_Occurrence_Of (Subp, Loc)); 1849 end if; 1850 1851 Resolve (N); 1852 end if; 1853 1854 -- Handle case of access to protected subprogram type 1855 1856 else 1857 if Ekind (Base_Type (Etype (Prefix (Name (N))))) = 1858 E_Access_Protected_Subprogram_Type 1859 then 1860 -- If this is a call through an access to protected operation, 1861 -- the prefix has the form (object'address, operation'access). 1862 -- Rewrite as a for other protected calls: the object is the 1863 -- first parameter of the list of actuals. 1864 1865 declare 1866 Call : Node_Id; 1867 Parm : List_Id; 1868 Nam : Node_Id; 1869 Obj : Node_Id; 1870 Ptr : constant Node_Id := Prefix (Name (N)); 1871 1872 T : constant Entity_Id := 1873 Equivalent_Type (Base_Type (Etype (Ptr))); 1874 1875 D_T : constant Entity_Id := 1876 Designated_Type (Base_Type (Etype (Ptr))); 1877 1878 begin 1879 Obj := Make_Selected_Component (Loc, 1880 Prefix => Unchecked_Convert_To (T, Ptr), 1881 Selector_Name => New_Occurrence_Of (First_Entity (T), Loc)); 1882 1883 Nam := Make_Selected_Component (Loc, 1884 Prefix => Unchecked_Convert_To (T, Ptr), 1885 Selector_Name => New_Occurrence_Of ( 1886 Next_Entity (First_Entity (T)), Loc)); 1887 1888 Nam := Make_Explicit_Dereference (Loc, Nam); 1889 1890 if Present (Parameter_Associations (N)) then 1891 Parm := Parameter_Associations (N); 1892 else 1893 Parm := New_List; 1894 end if; 1895 1896 Prepend (Obj, Parm); 1897 1898 if Etype (D_T) = Standard_Void_Type then 1899 Call := Make_Procedure_Call_Statement (Loc, 1900 Name => Nam, 1901 Parameter_Associations => Parm); 1902 else 1903 Call := Make_Function_Call (Loc, 1904 Name => Nam, 1905 Parameter_Associations => Parm); 1906 end if; 1907 1908 Set_First_Named_Actual (Call, First_Named_Actual (N)); 1909 Set_Etype (Call, Etype (D_T)); 1910 1911 -- We do not re-analyze the call to avoid infinite recursion. 1912 -- We analyze separately the prefix and the object, and set 1913 -- the checks on the prefix that would otherwise be emitted 1914 -- when resolving a call. 1915 1916 Rewrite (N, Call); 1917 Analyze (Nam); 1918 Apply_Access_Check (Nam); 1919 Analyze (Obj); 1920 return; 1921 end; 1922 end if; 1923 end if; 1924 1925 -- If this is a call to an intrinsic subprogram, then perform the 1926 -- appropriate expansion to the corresponding tree node and we 1927 -- are all done (since after that the call is gone!) 1928 1929 if Is_Intrinsic_Subprogram (Subp) then 1930 Expand_Intrinsic_Call (N, Subp); 1931 return; 1932 end if; 1933 1934 if Ekind (Subp) = E_Function 1935 or else Ekind (Subp) = E_Procedure 1936 then 1937 if Is_Inlined (Subp) then 1938 1939 declare 1940 Bod : Node_Id; 1941 Must_Inline : Boolean := False; 1942 Spec : constant Node_Id := Unit_Declaration_Node (Subp); 1943 Scop : constant Entity_Id := Scope (Subp); 1944 1945 begin 1946 -- Verify that the body to inline has already been seen, 1947 -- and that if the body is in the current unit the inlining 1948 -- does not occur earlier. This avoids order-of-elaboration 1949 -- problems in gigi. 1950 1951 if No (Spec) 1952 or else Nkind (Spec) /= N_Subprogram_Declaration 1953 or else No (Body_To_Inline (Spec)) 1954 then 1955 Must_Inline := False; 1956 1957 -- If this an inherited function that returns a private 1958 -- type, do not inline if the full view is an unconstrained 1959 -- array, because such calls cannot be inlined. 1960 1961 elsif Present (Orig_Subp) 1962 and then Is_Array_Type (Etype (Orig_Subp)) 1963 and then not Is_Constrained (Etype (Orig_Subp)) 1964 then 1965 Must_Inline := False; 1966 1967 -- If the subprogram comes from an instance in the same 1968 -- unit, and the instance is not yet frozen, inlining might 1969 -- trigger order-of-elaboration problems in gigi. 1970 1971 elsif Is_Generic_Instance (Scop) 1972 and then Present (Freeze_Node (Scop)) 1973 and then not Analyzed (Freeze_Node (Scop)) 1974 then 1975 Must_Inline := False; 1976 1977 else 1978 Bod := Body_To_Inline (Spec); 1979 1980 if (In_Extended_Main_Code_Unit (N) 1981 or else In_Extended_Main_Code_Unit (Parent (N)) 1982 or else Is_Always_Inlined (Subp)) 1983 and then (not In_Same_Extended_Unit (Sloc (Bod), Loc) 1984 or else 1985 Earlier_In_Extended_Unit (Sloc (Bod), Loc)) 1986 then 1987 Must_Inline := True; 1988 1989 -- If we are compiling a package body that is not the main 1990 -- unit, it must be for inlining/instantiation purposes, 1991 -- in which case we inline the call to insure that the same 1992 -- temporaries are generated when compiling the body by 1993 -- itself. Otherwise link errors can occur. 1994 1995 elsif not (In_Extended_Main_Code_Unit (N)) 1996 and then In_Package_Body 1997 then 1998 Must_Inline := True; 1999 end if; 2000 end if; 2001 2002 if Must_Inline then 2003 Expand_Inlined_Call (N, Subp, Orig_Subp); 2004 2005 else 2006 -- Let the back end handle it 2007 2008 Add_Inlined_Body (Subp); 2009 2010 if Front_End_Inlining 2011 and then Nkind (Spec) = N_Subprogram_Declaration 2012 and then (In_Extended_Main_Code_Unit (N)) 2013 and then No (Body_To_Inline (Spec)) 2014 and then not Has_Completion (Subp) 2015 and then In_Same_Extended_Unit (Sloc (Spec), Loc) 2016 then 2017 Cannot_Inline 2018 ("cannot inline& (body not seen yet)?", 2019 N, Subp); 2020 end if; 2021 end if; 2022 end; 2023 end if; 2024 end if; 2025 2026 -- Check for a protected subprogram. This is either an intra-object 2027 -- call, or a protected function call. Protected procedure calls are 2028 -- rewritten as entry calls and handled accordingly. 2029 2030 Scop := Scope (Subp); 2031 2032 if Nkind (N) /= N_Entry_Call_Statement 2033 and then Is_Protected_Type (Scop) 2034 then 2035 -- If the call is an internal one, it is rewritten as a call to 2036 -- to the corresponding unprotected subprogram. 2037 2038 Expand_Protected_Subprogram_Call (N, Subp, Scop); 2039 end if; 2040 2041 -- Functions returning controlled objects need special attention 2042 2043 if Controlled_Type (Etype (Subp)) 2044 and then not Is_Return_By_Reference_Type (Etype (Subp)) 2045 then 2046 Expand_Ctrl_Function_Call (N); 2047 end if; 2048 2049 -- Test for First_Optional_Parameter, and if so, truncate parameter 2050 -- list if there are optional parameters at the trailing end. 2051 -- Note we never delete procedures for call via a pointer. 2052 2053 if (Ekind (Subp) = E_Procedure or else Ekind (Subp) = E_Function) 2054 and then Present (First_Optional_Parameter (Subp)) 2055 then 2056 declare 2057 Last_Keep_Arg : Node_Id; 2058 2059 begin 2060 -- Last_Keep_Arg will hold the last actual that should be 2061 -- retained. If it remains empty at the end, it means that 2062 -- all parameters are optional. 2063 2064 Last_Keep_Arg := Empty; 2065 2066 -- Find first optional parameter, must be present since we 2067 -- checked the validity of the parameter before setting it. 2068 2069 Formal := First_Formal (Subp); 2070 Actual := First_Actual (N); 2071 while Formal /= First_Optional_Parameter (Subp) loop 2072 Last_Keep_Arg := Actual; 2073 Next_Formal (Formal); 2074 Next_Actual (Actual); 2075 end loop; 2076 2077 -- We have Formal and Actual pointing to the first potentially 2078 -- droppable argument. We can drop all the trailing arguments 2079 -- whose actual matches the default. Note that we know that all 2080 -- remaining formals have defaults, because we checked that this 2081 -- requirement was met before setting First_Optional_Parameter. 2082 2083 -- We use Fully_Conformant_Expressions to check for identity 2084 -- between formals and actuals, which may miss some cases, but 2085 -- on the other hand, this is only an optimization (if we fail 2086 -- to truncate a parameter it does not affect functionality). 2087 -- So if the default is 3 and the actual is 1+2, we consider 2088 -- them unequal, which hardly seems worrisome. 2089 2090 while Present (Formal) loop 2091 if not Fully_Conformant_Expressions 2092 (Actual, Default_Value (Formal)) 2093 then 2094 Last_Keep_Arg := Actual; 2095 end if; 2096 2097 Next_Formal (Formal); 2098 Next_Actual (Actual); 2099 end loop; 2100 2101 -- If no arguments, delete entire list, this is the easy case 2102 2103 if No (Last_Keep_Arg) then 2104 while Is_Non_Empty_List (Parameter_Associations (N)) loop 2105 Delete_Tree (Remove_Head (Parameter_Associations (N))); 2106 end loop; 2107 2108 Set_Parameter_Associations (N, No_List); 2109 Set_First_Named_Actual (N, Empty); 2110 2111 -- Case where at the last retained argument is positional. This 2112 -- is also an easy case, since the retained arguments are already 2113 -- in the right form, and we don't need to worry about the order 2114 -- of arguments that get eliminated. 2115 2116 elsif Is_List_Member (Last_Keep_Arg) then 2117 while Present (Next (Last_Keep_Arg)) loop 2118 Delete_Tree (Remove_Next (Last_Keep_Arg)); 2119 end loop; 2120 2121 Set_First_Named_Actual (N, Empty); 2122 2123 -- This is the annoying case where the last retained argument 2124 -- is a named parameter. Since the original arguments are not 2125 -- in declaration order, we may have to delete some fairly 2126 -- random collection of arguments. 2127 2128 else 2129 declare 2130 Temp : Node_Id; 2131 Passoc : Node_Id; 2132 2133 Discard : Node_Id; 2134 pragma Warnings (Off, Discard); 2135 2136 begin 2137 -- First step, remove all the named parameters from the 2138 -- list (they are still chained using First_Named_Actual 2139 -- and Next_Named_Actual, so we have not lost them!) 2140 2141 Temp := First (Parameter_Associations (N)); 2142 2143 -- Case of all parameters named, remove them all 2144 2145 if Nkind (Temp) = N_Parameter_Association then 2146 while Is_Non_Empty_List (Parameter_Associations (N)) loop 2147 Temp := Remove_Head (Parameter_Associations (N)); 2148 end loop; 2149 2150 -- Case of mixed positional/named, remove named parameters 2151 2152 else 2153 while Nkind (Next (Temp)) /= N_Parameter_Association loop 2154 Next (Temp); 2155 end loop; 2156 2157 while Present (Next (Temp)) loop 2158 Discard := Remove_Next (Temp); 2159 end loop; 2160 end if; 2161 2162 -- Now we loop through the named parameters, till we get 2163 -- to the last one to be retained, adding them to the list. 2164 -- Note that the Next_Named_Actual list does not need to be 2165 -- touched since we are only reordering them on the actual 2166 -- parameter association list. 2167 2168 Passoc := Parent (First_Named_Actual (N)); 2169 loop 2170 Temp := Relocate_Node (Passoc); 2171 Append_To 2172 (Parameter_Associations (N), Temp); 2173 exit when 2174 Last_Keep_Arg = Explicit_Actual_Parameter (Passoc); 2175 Passoc := Parent (Next_Named_Actual (Passoc)); 2176 end loop; 2177 2178 Set_Next_Named_Actual (Temp, Empty); 2179 2180 loop 2181 Temp := Next_Named_Actual (Passoc); 2182 exit when No (Temp); 2183 Set_Next_Named_Actual 2184 (Passoc, Next_Named_Actual (Parent (Temp))); 2185 Delete_Tree (Temp); 2186 end loop; 2187 end; 2188 end if; 2189 end; 2190 end if; 2191 end Expand_Call; 2192 2193 -------------------------- 2194 -- Expand_Inlined_Call -- 2195 -------------------------- 2196 2197 procedure Expand_Inlined_Call 2198 (N : Node_Id; 2199 Subp : Entity_Id; 2200 Orig_Subp : Entity_Id) 2201 is 2202 Loc : constant Source_Ptr := Sloc (N); 2203 Is_Predef : constant Boolean := 2204 Is_Predefined_File_Name 2205 (Unit_File_Name (Get_Source_Unit (Subp))); 2206 Orig_Bod : constant Node_Id := 2207 Body_To_Inline (Unit_Declaration_Node (Subp)); 2208 2209 Blk : Node_Id; 2210 Bod : Node_Id; 2211 Decl : Node_Id; 2212 Exit_Lab : Entity_Id := Empty; 2213 F : Entity_Id; 2214 A : Node_Id; 2215 Lab_Decl : Node_Id; 2216 Lab_Id : Node_Id; 2217 New_A : Node_Id; 2218 Num_Ret : Int := 0; 2219 Ret_Type : Entity_Id; 2220 Targ : Node_Id; 2221 Temp : Entity_Id; 2222 Temp_Typ : Entity_Id; 2223 2224 procedure Make_Exit_Label; 2225 -- Build declaration for exit label to be used in Return statements. 2226 2227 function Process_Formals (N : Node_Id) return Traverse_Result; 2228 -- Replace occurrence of a formal with the corresponding actual, or 2229 -- the thunk generated for it. 2230 2231 function Process_Sloc (Nod : Node_Id) return Traverse_Result; 2232 -- If the call being expanded is that of an internal subprogram, 2233 -- set the sloc of the generated block to that of the call itself, 2234 -- so that the expansion is skipped by the -next- command in gdb. 2235 -- Same processing for a subprogram in a predefined file, e.g. 2236 -- Ada.Tags. If Debug_Generated_Code is true, suppress this change 2237 -- to simplify our own development. 2238 2239 procedure Rewrite_Function_Call (N : Node_Id; Blk : Node_Id); 2240 -- If the function body is a single expression, replace call with 2241 -- expression, else insert block appropriately. 2242 2243 procedure Rewrite_Procedure_Call (N : Node_Id; Blk : Node_Id); 2244 -- If procedure body has no local variables, inline body without 2245 -- creating block, otherwise rewrite call with block. 2246 2247 --------------------- 2248 -- Make_Exit_Label -- 2249 --------------------- 2250 2251 procedure Make_Exit_Label is 2252 begin 2253 -- Create exit label for subprogram, if one doesn't exist yet. 2254 2255 if No (Exit_Lab) then 2256 Lab_Id := Make_Identifier (Loc, New_Internal_Name ('L')); 2257 Set_Entity (Lab_Id, 2258 Make_Defining_Identifier (Loc, Chars (Lab_Id))); 2259 Exit_Lab := Make_Label (Loc, Lab_Id); 2260 2261 Lab_Decl := 2262 Make_Implicit_Label_Declaration (Loc, 2263 Defining_Identifier => Entity (Lab_Id), 2264 Label_Construct => Exit_Lab); 2265 end if; 2266 end Make_Exit_Label; 2267 2268 --------------------- 2269 -- Process_Formals -- 2270 --------------------- 2271 2272 function Process_Formals (N : Node_Id) return Traverse_Result is 2273 A : Entity_Id; 2274 E : Entity_Id; 2275 Ret : Node_Id; 2276 2277 begin 2278 if Is_Entity_Name (N) 2279 and then Present (Entity (N)) 2280 then 2281 E := Entity (N); 2282 2283 if Is_Formal (E) 2284 and then Scope (E) = Subp 2285 then 2286 A := Renamed_Object (E); 2287 2288 if Is_Entity_Name (A) then 2289 Rewrite (N, New_Occurrence_Of (Entity (A), Loc)); 2290 2291 elsif Nkind (A) = N_Defining_Identifier then 2292 Rewrite (N, New_Occurrence_Of (A, Loc)); 2293 2294 else -- numeric literal 2295 Rewrite (N, New_Copy (A)); 2296 end if; 2297 end if; 2298 2299 return Skip; 2300 2301 elsif Nkind (N) = N_Return_Statement then 2302 2303 if No (Expression (N)) then 2304 Make_Exit_Label; 2305 Rewrite (N, Make_Goto_Statement (Loc, 2306 Name => New_Copy (Lab_Id))); 2307 2308 else 2309 if Nkind (Parent (N)) = N_Handled_Sequence_Of_Statements 2310 and then Nkind (Parent (Parent (N))) = N_Subprogram_Body 2311 then 2312 -- Function body is a single expression. No need for 2313 -- exit label. 2314 2315 null; 2316 2317 else 2318 Num_Ret := Num_Ret + 1; 2319 Make_Exit_Label; 2320 end if; 2321 2322 -- Because of the presence of private types, the views of the 2323 -- expression and the context may be different, so place an 2324 -- unchecked conversion to the context type to avoid spurious 2325 -- errors, eg. when the expression is a numeric literal and 2326 -- the context is private. If the expression is an aggregate, 2327 -- use a qualified expression, because an aggregate is not a 2328 -- legal argument of a conversion. 2329 2330 if Nkind (Expression (N)) = N_Aggregate 2331 or else Nkind (Expression (N)) = N_Null 2332 then 2333 Ret := 2334 Make_Qualified_Expression (Sloc (N), 2335 Subtype_Mark => New_Occurrence_Of (Ret_Type, Sloc (N)), 2336 Expression => Relocate_Node (Expression (N))); 2337 else 2338 Ret := 2339 Unchecked_Convert_To 2340 (Ret_Type, Relocate_Node (Expression (N))); 2341 end if; 2342 2343 if Nkind (Targ) = N_Defining_Identifier then 2344 Rewrite (N, 2345 Make_Assignment_Statement (Loc, 2346 Name => New_Occurrence_Of (Targ, Loc), 2347 Expression => Ret)); 2348 else 2349 Rewrite (N, 2350 Make_Assignment_Statement (Loc, 2351 Name => New_Copy (Targ), 2352 Expression => Ret)); 2353 end if; 2354 2355 Set_Assignment_OK (Name (N)); 2356 2357 if Present (Exit_Lab) then 2358 Insert_After (N, 2359 Make_Goto_Statement (Loc, 2360 Name => New_Copy (Lab_Id))); 2361 end if; 2362 end if; 2363 2364 return OK; 2365 2366 -- Remove pragma Unreferenced since it may refer to formals that 2367 -- are not visible in the inlined body, and in any case we will 2368 -- not be posting warnings on the inlined body so it is unneeded. 2369 2370 elsif Nkind (N) = N_Pragma 2371 and then Chars (N) = Name_Unreferenced 2372 then 2373 Rewrite (N, Make_Null_Statement (Sloc (N))); 2374 return OK; 2375 2376 else 2377 return OK; 2378 end if; 2379 end Process_Formals; 2380 2381 procedure Replace_Formals is new Traverse_Proc (Process_Formals); 2382 2383 ------------------ 2384 -- Process_Sloc -- 2385 ------------------ 2386 2387 function Process_Sloc (Nod : Node_Id) return Traverse_Result is 2388 begin 2389 if not Debug_Generated_Code then 2390 Set_Sloc (Nod, Sloc (N)); 2391 Set_Comes_From_Source (Nod, False); 2392 end if; 2393 2394 return OK; 2395 end Process_Sloc; 2396 2397 procedure Reset_Slocs is new Traverse_Proc (Process_Sloc); 2398 2399 --------------------------- 2400 -- Rewrite_Function_Call -- 2401 --------------------------- 2402 2403 procedure Rewrite_Function_Call (N : Node_Id; Blk : Node_Id) is 2404 HSS : constant Node_Id := Handled_Statement_Sequence (Blk); 2405 Fst : constant Node_Id := First (Statements (HSS)); 2406 2407 begin 2408 -- Optimize simple case: function body is a single return statement, 2409 -- which has been expanded into an assignment. 2410 2411 if Is_Empty_List (Declarations (Blk)) 2412 and then Nkind (Fst) = N_Assignment_Statement 2413 and then No (Next (Fst)) 2414 then 2415 2416 -- The function call may have been rewritten as the temporary 2417 -- that holds the result of the call, in which case remove the 2418 -- now useless declaration. 2419 2420 if Nkind (N) = N_Identifier 2421 and then Nkind (Parent (Entity (N))) = N_Object_Declaration 2422 then 2423 Rewrite (Parent (Entity (N)), Make_Null_Statement (Loc)); 2424 end if; 2425 2426 Rewrite (N, Expression (Fst)); 2427 2428 elsif Nkind (N) = N_Identifier 2429 and then Nkind (Parent (Entity (N))) = N_Object_Declaration 2430 then 2431 2432 -- The block assigns the result of the call to the temporary. 2433 2434 Insert_After (Parent (Entity (N)), Blk); 2435 2436 elsif Nkind (Parent (N)) = N_Assignment_Statement 2437 and then Is_Entity_Name (Name (Parent (N))) 2438 then 2439 2440 -- Replace assignment with the block 2441 2442 Rewrite (Parent (N), Blk); 2443 2444 elsif Nkind (Parent (N)) = N_Object_Declaration then 2445 Set_Expression (Parent (N), Empty); 2446 Insert_After (Parent (N), Blk); 2447 end if; 2448 end Rewrite_Function_Call; 2449 2450 ---------------------------- 2451 -- Rewrite_Procedure_Call -- 2452 ---------------------------- 2453 2454 procedure Rewrite_Procedure_Call (N : Node_Id; Blk : Node_Id) is 2455 HSS : constant Node_Id := Handled_Statement_Sequence (Blk); 2456 2457 begin 2458 if Is_Empty_List (Declarations (Blk)) then 2459 Insert_List_After (N, Statements (HSS)); 2460 Rewrite (N, Make_Null_Statement (Loc)); 2461 else 2462 Rewrite (N, Blk); 2463 end if; 2464 end Rewrite_Procedure_Call; 2465 2466 -- Start of processing for Expand_Inlined_Call 2467 2468 begin 2469 -- Check for special case of To_Address call, and if so, just 2470 -- do an unchecked conversion instead of expanding the call. 2471 -- Not only is this more efficient, but it also avoids a 2472 -- problem with order of elaboration when address clauses 2473 -- are inlined (address expr elaborated at wrong point). 2474 2475 if Subp = RTE (RE_To_Address) then 2476 Rewrite (N, 2477 Unchecked_Convert_To 2478 (RTE (RE_Address), 2479 Relocate_Node (First_Actual (N)))); 2480 return; 2481 end if; 2482 2483 if Nkind (Orig_Bod) = N_Defining_Identifier then 2484 2485 -- Subprogram is a renaming_as_body. Calls appearing after the 2486 -- renaming can be replaced with calls to the renamed entity 2487 -- directly, because the subprograms are subtype conformant. 2488 2489 Set_Name (N, New_Occurrence_Of (Orig_Bod, Loc)); 2490 return; 2491 end if; 2492 2493 -- Use generic machinery to copy body of inlined subprogram, as if it 2494 -- were an instantiation, resetting source locations appropriately, so 2495 -- that nested inlined calls appear in the main unit. 2496 2497 Save_Env (Subp, Empty); 2498 Set_Copied_Sloc_For_Inlined_Body (N, Defining_Entity (Orig_Bod)); 2499 2500 Bod := Copy_Generic_Node (Orig_Bod, Empty, Instantiating => True); 2501 Blk := 2502 Make_Block_Statement (Loc, 2503 Declarations => Declarations (Bod), 2504 Handled_Statement_Sequence => Handled_Statement_Sequence (Bod)); 2505 2506 if No (Declarations (Bod)) then 2507 Set_Declarations (Blk, New_List); 2508 end if; 2509 2510 -- If this is a derived function, establish the proper return type. 2511 2512 if Present (Orig_Subp) 2513 and then Orig_Subp /= Subp 2514 then 2515 Ret_Type := Etype (Orig_Subp); 2516 else 2517 Ret_Type := Etype (Subp); 2518 end if; 2519 2520 F := First_Formal (Subp); 2521 A := First_Actual (N); 2522 2523 -- Create temporaries for the actuals that are expressions, or that 2524 -- are scalars and require copying to preserve semantics. 2525 2526 while Present (F) loop 2527 if Present (Renamed_Object (F)) then 2528 Error_Msg_N (" cannot inline call to recursive subprogram", N); 2529 return; 2530 end if; 2531 2532 -- If the argument may be a controlling argument in a call within 2533 -- the inlined body, we must preserve its classwide nature to 2534 -- insure that dynamic dispatching take place subsequently. 2535 -- If the formal has a constraint it must be preserved to retain 2536 -- the semantics of the body. 2537 2538 if Is_Class_Wide_Type (Etype (F)) 2539 or else (Is_Access_Type (Etype (F)) 2540 and then 2541 Is_Class_Wide_Type (Designated_Type (Etype (F)))) 2542 then 2543 Temp_Typ := Etype (F); 2544 2545 elsif Base_Type (Etype (F)) = Base_Type (Etype (A)) 2546 and then Etype (F) /= Base_Type (Etype (F)) 2547 then 2548 Temp_Typ := Etype (F); 2549 2550 else 2551 Temp_Typ := Etype (A); 2552 end if; 2553 2554 -- If the actual is a simple name or a literal, no need to 2555 -- create a temporary, object can be used directly. 2556 2557 if (Is_Entity_Name (A) 2558 and then 2559 (not Is_Scalar_Type (Etype (A)) 2560 or else Ekind (Entity (A)) = E_Enumeration_Literal)) 2561 2562 or else Nkind (A) = N_Real_Literal 2563 or else Nkind (A) = N_Integer_Literal 2564 or else Nkind (A) = N_Character_Literal 2565 then 2566 if Etype (F) /= Etype (A) then 2567 Set_Renamed_Object 2568 (F, Unchecked_Convert_To (Etype (F), Relocate_Node (A))); 2569 else 2570 Set_Renamed_Object (F, A); 2571 end if; 2572 2573 else 2574 Temp := 2575 Make_Defining_Identifier (Loc, 2576 Chars => New_Internal_Name ('C')); 2577 2578 -- If the actual for an in/in-out parameter is a view conversion, 2579 -- make it into an unchecked conversion, given that an untagged 2580 -- type conversion is not a proper object for a renaming. 2581 2582 -- In-out conversions that involve real conversions have already 2583 -- been transformed in Expand_Actuals. 2584 2585 if Nkind (A) = N_Type_Conversion 2586 and then Ekind (F) /= E_In_Parameter 2587 then 2588 New_A := Make_Unchecked_Type_Conversion (Loc, 2589 Subtype_Mark => New_Occurrence_Of (Etype (F), Loc), 2590 Expression => Relocate_Node (Expression (A))); 2591 2592 elsif Etype (F) /= Etype (A) then 2593 New_A := Unchecked_Convert_To (Etype (F), Relocate_Node (A)); 2594 Temp_Typ := Etype (F); 2595 2596 else 2597 New_A := Relocate_Node (A); 2598 end if; 2599 2600 Set_Sloc (New_A, Sloc (N)); 2601 2602 if Ekind (F) = E_In_Parameter 2603 and then not Is_Limited_Type (Etype (A)) 2604 then 2605 Decl := 2606 Make_Object_Declaration (Loc, 2607 Defining_Identifier => Temp, 2608 Constant_Present => True, 2609 Object_Definition => New_Occurrence_Of (Temp_Typ, Loc), 2610 Expression => New_A); 2611 else 2612 Decl := 2613 Make_Object_Renaming_Declaration (Loc, 2614 Defining_Identifier => Temp, 2615 Subtype_Mark => New_Occurrence_Of (Temp_Typ, Loc), 2616 Name => New_A); 2617 end if; 2618 2619 Prepend (Decl, Declarations (Blk)); 2620 Set_Renamed_Object (F, Temp); 2621 end if; 2622 2623 Next_Formal (F); 2624 Next_Actual (A); 2625 end loop; 2626 2627 -- Establish target of function call. If context is not assignment or 2628 -- declaration, create a temporary as a target. The declaration for 2629 -- the temporary may be subsequently optimized away if the body is a 2630 -- single expression, or if the left-hand side of the assignment is 2631 -- simple enough. 2632 2633 if Ekind (Subp) = E_Function then 2634 if Nkind (Parent (N)) = N_Assignment_Statement 2635 and then Is_Entity_Name (Name (Parent (N))) 2636 then 2637 Targ := Name (Parent (N)); 2638 2639 else 2640 -- Replace call with temporary, and create its declaration. 2641 2642 Temp := 2643 Make_Defining_Identifier (Loc, New_Internal_Name ('C')); 2644 2645 Decl := 2646 Make_Object_Declaration (Loc, 2647 Defining_Identifier => Temp, 2648 Object_Definition => 2649 New_Occurrence_Of (Ret_Type, Loc)); 2650 2651 Set_No_Initialization (Decl); 2652 Insert_Action (N, Decl); 2653 Rewrite (N, New_Occurrence_Of (Temp, Loc)); 2654 Targ := Temp; 2655 end if; 2656 end if; 2657 2658 -- Traverse the tree and replace formals with actuals or their thunks. 2659 -- Attach block to tree before analysis and rewriting. 2660 2661 Replace_Formals (Blk); 2662 Set_Parent (Blk, N); 2663 2664 if not Comes_From_Source (Subp) 2665 or else Is_Predef 2666 then 2667 Reset_Slocs (Blk); 2668 end if; 2669 2670 if Present (Exit_Lab) then 2671 2672 -- If the body was a single expression, the single return statement 2673 -- and the corresponding label are useless. 2674 2675 if Num_Ret = 1 2676 and then 2677 Nkind (Last (Statements (Handled_Statement_Sequence (Blk)))) = 2678 N_Goto_Statement 2679 then 2680 Remove (Last (Statements (Handled_Statement_Sequence (Blk)))); 2681 else 2682 Append (Lab_Decl, (Declarations (Blk))); 2683 Append (Exit_Lab, Statements (Handled_Statement_Sequence (Blk))); 2684 end if; 2685 end if; 2686 2687 -- Analyze Blk with In_Inlined_Body set, to avoid spurious errors on 2688 -- conflicting private views that Gigi would ignore. If this is a 2689 -- predefined unit, analyze with checks off, as is done in the non- 2690 -- inlined run-time units. 2691 2692 declare 2693 I_Flag : constant Boolean := In_Inlined_Body; 2694 2695 begin 2696 In_Inlined_Body := True; 2697 2698 if Is_Predef then 2699 declare 2700 Style : constant Boolean := Style_Check; 2701 begin 2702 Style_Check := False; 2703 Analyze (Blk, Suppress => All_Checks); 2704 Style_Check := Style; 2705 end; 2706 2707 else 2708 Analyze (Blk); 2709 end if; 2710 2711 In_Inlined_Body := I_Flag; 2712 end; 2713 2714 if Ekind (Subp) = E_Procedure then 2715 Rewrite_Procedure_Call (N, Blk); 2716 else 2717 Rewrite_Function_Call (N, Blk); 2718 end if; 2719 2720 Restore_Env; 2721 2722 -- Cleanup mapping between formals and actuals, for other expansions. 2723 2724 F := First_Formal (Subp); 2725 2726 while Present (F) loop 2727 Set_Renamed_Object (F, Empty); 2728 Next_Formal (F); 2729 end loop; 2730 end Expand_Inlined_Call; 2731 2732 ---------------------------- 2733 -- Expand_N_Function_Call -- 2734 ---------------------------- 2735 2736 procedure Expand_N_Function_Call (N : Node_Id) is 2737 Typ : constant Entity_Id := Etype (N); 2738 2739 function Returned_By_Reference return Boolean; 2740 -- If the return type is returned through the secondary stack. that is 2741 -- by reference, we don't want to create a temp to force stack checking. 2742 2743 function Returned_By_Reference return Boolean is 2744 S : Entity_Id := Current_Scope; 2745 2746 begin 2747 if Is_Return_By_Reference_Type (Typ) then 2748 return True; 2749 2750 elsif Nkind (Parent (N)) /= N_Return_Statement then 2751 return False; 2752 2753 elsif Requires_Transient_Scope (Typ) then 2754 2755 -- Verify that the return type of the enclosing function has 2756 -- the same constrained status as that of the expression. 2757 2758 while Ekind (S) /= E_Function loop 2759 S := Scope (S); 2760 end loop; 2761 2762 return Is_Constrained (Typ) = Is_Constrained (Etype (S)); 2763 else 2764 return False; 2765 end if; 2766 end Returned_By_Reference; 2767 2768 -- Start of processing for Expand_N_Function_Call 2769 2770 begin 2771 -- A special check. If stack checking is enabled, and the return type 2772 -- might generate a large temporary, and the call is not the right 2773 -- side of an assignment, then generate an explicit temporary. We do 2774 -- this because otherwise gigi may generate a large temporary on the 2775 -- fly and this can cause trouble with stack checking. 2776 2777 if May_Generate_Large_Temp (Typ) 2778 and then Nkind (Parent (N)) /= N_Assignment_Statement 2779 and then 2780 (Nkind (Parent (N)) /= N_Qualified_Expression 2781 or else Nkind (Parent (Parent (N))) /= N_Assignment_Statement) 2782 and then 2783 (Nkind (Parent (N)) /= N_Object_Declaration 2784 or else Expression (Parent (N)) /= N) 2785 and then not Returned_By_Reference 2786 then 2787 -- Note: it might be thought that it would be OK to use a call to 2788 -- Force_Evaluation here, but that's not good enough, because that 2789 -- results in a 'Reference construct that may still need a temporary. 2790 2791 declare 2792 Loc : constant Source_Ptr := Sloc (N); 2793 Temp_Obj : constant Entity_Id := 2794 Make_Defining_Identifier (Loc, 2795 Chars => New_Internal_Name ('F')); 2796 Temp_Typ : Entity_Id := Typ; 2797 Decl : Node_Id; 2798 A : Node_Id; 2799 F : Entity_Id; 2800 Proc : Entity_Id; 2801 2802 begin 2803 if Is_Tagged_Type (Typ) 2804 and then Present (Controlling_Argument (N)) 2805 then 2806 if Nkind (Parent (N)) /= N_Procedure_Call_Statement 2807 and then Nkind (Parent (N)) /= N_Function_Call 2808 then 2809 -- If this is a tag-indeterminate call, the object must 2810 -- be classwide. 2811 2812 if Is_Tag_Indeterminate (N) then 2813 Temp_Typ := Class_Wide_Type (Typ); 2814 end if; 2815 2816 else 2817 -- If this is a dispatching call that is itself the 2818 -- controlling argument of an enclosing call, the nominal 2819 -- subtype of the object that replaces it must be classwide, 2820 -- so that dispatching will take place properly. If it is 2821 -- not a controlling argument, the object is not classwide. 2822 2823 Proc := Entity (Name (Parent (N))); 2824 F := First_Formal (Proc); 2825 A := First_Actual (Parent (N)); 2826 2827 while A /= N loop 2828 Next_Formal (F); 2829 Next_Actual (A); 2830 end loop; 2831 2832 if Is_Controlling_Formal (F) then 2833 Temp_Typ := Class_Wide_Type (Typ); 2834 end if; 2835 end if; 2836 end if; 2837 2838 Decl := 2839 Make_Object_Declaration (Loc, 2840 Defining_Identifier => Temp_Obj, 2841 Object_Definition => New_Occurrence_Of (Temp_Typ, Loc), 2842 Constant_Present => True, 2843 Expression => Relocate_Node (N)); 2844 Set_Assignment_OK (Decl); 2845 2846 Insert_Actions (N, New_List (Decl)); 2847 Rewrite (N, New_Occurrence_Of (Temp_Obj, Loc)); 2848 end; 2849 2850 -- Normal case, expand the call 2851 2852 else 2853 Expand_Call (N); 2854 end if; 2855 end Expand_N_Function_Call; 2856 2857 --------------------------------------- 2858 -- Expand_N_Procedure_Call_Statement -- 2859 --------------------------------------- 2860 2861 procedure Expand_N_Procedure_Call_Statement (N : Node_Id) is 2862 begin 2863 Expand_Call (N); 2864 end Expand_N_Procedure_Call_Statement; 2865 2866 ------------------------------ 2867 -- Expand_N_Subprogram_Body -- 2868 ------------------------------ 2869 2870 -- Add poll call if ATC polling is enabled 2871 2872 -- Add return statement if last statement in body is not a return 2873 -- statement (this makes things easier on Gigi which does not want 2874 -- to have to handle a missing return). 2875 2876 -- Add call to Activate_Tasks if body is a task activator 2877 2878 -- Deal with possible detection of infinite recursion 2879 2880 -- Eliminate body completely if convention stubbed 2881 2882 -- Encode entity names within body, since we will not need to reference 2883 -- these entities any longer in the front end. 2884 2885 -- Initialize scalar out parameters if Initialize/Normalize_Scalars 2886 2887 -- Reset Pure indication if any parameter has root type System.Address 2888 2889 -- Wrap thread body 2890 2891 procedure Expand_N_Subprogram_Body (N : Node_Id) is 2892 Loc : constant Source_Ptr := Sloc (N); 2893 H : constant Node_Id := Handled_Statement_Sequence (N); 2894 Body_Id : Entity_Id; 2895 Spec_Id : Entity_Id; 2896 Except_H : Node_Id; 2897 Scop : Entity_Id; 2898 Dec : Node_Id; 2899 Next_Op : Node_Id; 2900 L : List_Id; 2901 2902 procedure Add_Return (S : List_Id); 2903 -- Append a return statement to the statement sequence S if the last 2904 -- statement is not already a return or a goto statement. Note that 2905 -- the latter test is not critical, it does not matter if we add a 2906 -- few extra returns, since they get eliminated anyway later on. 2907 2908 procedure Expand_Thread_Body; 2909 -- Perform required expansion of a thread body 2910 2911 ---------------- 2912 -- Add_Return -- 2913 ---------------- 2914 2915 procedure Add_Return (S : List_Id) is 2916 begin 2917 if not Is_Transfer (Last (S)) then 2918 2919 -- The source location for the return is the end label 2920 -- of the procedure in all cases. This is a bit odd when 2921 -- there are exception handlers, but not much else we can do. 2922 2923 Append_To (S, Make_Return_Statement (Sloc (End_Label (H)))); 2924 end if; 2925 end Add_Return; 2926 2927 ------------------------ 2928 -- Expand_Thread_Body -- 2929 ------------------------ 2930 2931 -- The required expansion of a thread body is as follows 2932 2933 -- procedure <thread body procedure name> is 2934 2935 -- _Secondary_Stack : aliased 2936 -- Storage_Elements.Storage_Array 2937 -- (1 .. Storage_Offset (Sec_Stack_Size)); 2938 -- for _Secondary_Stack'Alignment use Standard'Maximum_Alignment; 2939 2940 -- _Process_ATSD : aliased System.Threads.ATSD; 2941 2942 -- begin 2943 -- System.Threads.Thread_Body_Enter; 2944 -- (_Secondary_Stack'Address, 2945 -- _Secondary_Stack'Length, 2946 -- _Process_ATSD'Address); 2947 2948 -- declare 2949 -- <user declarations> 2950 -- begin 2951 -- <user statements> 2952 -- <user exception handlers> 2953 -- end; 2954 2955 -- System.Threads.Thread_Body_Leave; 2956 2957 -- exception 2958 -- when E : others => 2959 -- System.Threads.Thread_Body_Exceptional_Exit (E); 2960 -- end; 2961 2962 -- Note the exception handler is omitted if pragma Restriction 2963 -- No_Exception_Handlers is currently active. 2964 2965 procedure Expand_Thread_Body is 2966 User_Decls : constant List_Id := Declarations (N); 2967 Sec_Stack_Len : Node_Id; 2968 2969 TB_Pragma : constant Node_Id := 2970 Get_Rep_Pragma (Spec_Id, Name_Thread_Body); 2971 2972 Ent_SS : Entity_Id; 2973 Ent_ATSD : Entity_Id; 2974 Ent_EO : Entity_Id; 2975 2976 Decl_SS : Node_Id; 2977 Decl_ATSD : Node_Id; 2978 2979 Excep_Handlers : List_Id; 2980 2981 begin 2982 New_Scope (Spec_Id); 2983 2984 -- Get proper setting for secondary stack size 2985 2986 if List_Length (Pragma_Argument_Associations (TB_Pragma)) = 2 then 2987 Sec_Stack_Len := 2988 Expression (Last (Pragma_Argument_Associations (TB_Pragma))); 2989 else 2990 Sec_Stack_Len := 2991 New_Occurrence_Of (RTE (RE_Default_Secondary_Stack_Size), Loc); 2992 end if; 2993 2994 Sec_Stack_Len := Convert_To (RTE (RE_Storage_Offset), Sec_Stack_Len); 2995 2996 -- Build and set declarations for the wrapped thread body 2997 2998 Ent_SS := Make_Defining_Identifier (Loc, Name_uSecondary_Stack); 2999 Ent_ATSD := Make_Defining_Identifier (Loc, Name_uProcess_ATSD); 3000 3001 Decl_SS := 3002 Make_Object_Declaration (Loc, 3003 Defining_Identifier => Ent_SS, 3004 Aliased_Present => True, 3005 Object_Definition => 3006 Make_Subtype_Indication (Loc, 3007 Subtype_Mark => 3008 New_Occurrence_Of (RTE (RE_Storage_Array), Loc), 3009 Constraint => 3010 Make_Index_Or_Discriminant_Constraint (Loc, 3011 Constraints => New_List ( 3012 Make_Range (Loc, 3013 Low_Bound => Make_Integer_Literal (Loc, 1), 3014 High_Bound => Sec_Stack_Len))))); 3015 3016 Decl_ATSD := 3017 Make_Object_Declaration (Loc, 3018 Defining_Identifier => Ent_ATSD, 3019 Aliased_Present => True, 3020 Object_Definition => New_Occurrence_Of (RTE (RE_ATSD), Loc)); 3021 3022 Set_Declarations (N, New_List (Decl_SS, Decl_ATSD)); 3023 Analyze (Decl_SS); 3024 Analyze (Decl_ATSD); 3025 Set_Alignment (Ent_SS, UI_From_Int (Maximum_Alignment)); 3026 3027 -- Create new exception handler 3028 3029 if Restrictions (No_Exception_Handlers) then 3030 Excep_Handlers := No_List; 3031 3032 else 3033 Check_Restriction (No_Exception_Handlers, N); 3034 3035 Ent_EO := Make_Defining_Identifier (Loc, Name_uE); 3036 3037 Excep_Handlers := New_List ( 3038 Make_Exception_Handler (Loc, 3039 Choice_Parameter => Ent_EO, 3040 Exception_Choices => New_List ( 3041 Make_Others_Choice (Loc)), 3042 Statements => New_List ( 3043 Make_Procedure_Call_Statement (Loc, 3044 Name => 3045 New_Occurrence_Of 3046 (RTE (RE_Thread_Body_Exceptional_Exit), Loc), 3047 Parameter_Associations => New_List ( 3048 New_Occurrence_Of (Ent_EO, Loc)))))); 3049 end if; 3050 3051 -- Now build new handled statement sequence and analyze it 3052 3053 Set_Handled_Statement_Sequence (N, 3054 Make_Handled_Sequence_Of_Statements (Loc, 3055 Statements => New_List ( 3056 3057 Make_Procedure_Call_Statement (Loc, 3058 Name => New_Occurrence_Of (RTE (RE_Thread_Body_Enter), Loc), 3059 Parameter_Associations => New_List ( 3060 3061 Make_Attribute_Reference (Loc, 3062 Prefix => New_Occurrence_Of (Ent_SS, Loc), 3063 Attribute_Name => Name_Address), 3064 3065 Make_Attribute_Reference (Loc, 3066 Prefix => New_Occurrence_Of (Ent_SS, Loc), 3067 Attribute_Name => Name_Length), 3068 3069 Make_Attribute_Reference (Loc, 3070 Prefix => New_Occurrence_Of (Ent_ATSD, Loc), 3071 Attribute_Name => Name_Address))), 3072 3073 Make_Block_Statement (Loc, 3074 Declarations => User_Decls, 3075 Handled_Statement_Sequence => H), 3076 3077 Make_Procedure_Call_Statement (Loc, 3078 Name => New_Occurrence_Of (RTE (RE_Thread_Body_Leave), Loc))), 3079 3080 Exception_Handlers => Excep_Handlers)); 3081 3082 Analyze (Handled_Statement_Sequence (N)); 3083 End_Scope; 3084 end Expand_Thread_Body; 3085 3086 -- Start of processing for Expand_N_Subprogram_Body 3087 3088 begin 3089 -- Set L to either the list of declarations if present, or 3090 -- to the list of statements if no declarations are present. 3091 -- This is used to insert new stuff at the start. 3092 3093 if Is_Non_Empty_List (Declarations (N)) then 3094 L := Declarations (N); 3095 else 3096 L := Statements (Handled_Statement_Sequence (N)); 3097 end if; 3098 3099 -- Need poll on entry to subprogram if polling enabled. We only 3100 -- do this for non-empty subprograms, since it does not seem 3101 -- necessary to poll for a dummy null subprogram. 3102 3103 if Is_Non_Empty_List (L) then 3104 Generate_Poll_Call (First (L)); 3105 end if; 3106 3107 -- Find entity for subprogram 3108 3109 Body_Id := Defining_Entity (N); 3110 3111 if Present (Corresponding_Spec (N)) then 3112 Spec_Id := Corresponding_Spec (N); 3113 else 3114 Spec_Id := Body_Id; 3115 end if; 3116 3117 -- If this is a Pure function which has any parameters whose root 3118 -- type is System.Address, reset the Pure indication, since it will 3119 -- likely cause incorrect code to be generated as the parameter is 3120 -- probably a pointer, and the fact that the same pointer is passed 3121 -- does not mean that the same value is being referenced. 3122 3123 -- Note that if the programmer gave an explicit Pure_Function pragma, 3124 -- then we believe the programmer, and leave the subprogram Pure. 3125 3126 -- This code should probably be at the freeze point, so that it 3127 -- happens even on a -gnatc (or more importantly -gnatt) compile 3128 -- so that the semantic tree has Is_Pure set properly ??? 3129 3130 if Is_Pure (Spec_Id) 3131 and then Is_Subprogram (Spec_Id) 3132 and then not Has_Pragma_Pure_Function (Spec_Id) 3133 then 3134 declare 3135 F : Entity_Id := First_Formal (Spec_Id); 3136 3137 begin 3138 while Present (F) loop 3139 if Is_RTE (Root_Type (Etype (F)), RE_Address) then 3140 Set_Is_Pure (Spec_Id, False); 3141 3142 if Spec_Id /= Body_Id then 3143 Set_Is_Pure (Body_Id, False); 3144 end if; 3145 3146 exit; 3147 end if; 3148 3149 Next_Formal (F); 3150 end loop; 3151 end; 3152 end if; 3153 3154 -- Initialize any scalar OUT args if Initialize/Normalize_Scalars 3155 3156 if Init_Or_Norm_Scalars and then Is_Subprogram (Spec_Id) then 3157 declare 3158 F : Entity_Id := First_Formal (Spec_Id); 3159 V : constant Boolean := Validity_Checks_On; 3160 3161 begin 3162 -- We turn off validity checking, since we do not want any 3163 -- check on the initializing value itself (which we know 3164 -- may well be invalid!) 3165 3166 Validity_Checks_On := False; 3167 3168 -- Loop through formals 3169 3170 while Present (F) loop 3171 if Is_Scalar_Type (Etype (F)) 3172 and then Ekind (F) = E_Out_Parameter 3173 then 3174 Insert_Before_And_Analyze (First (L), 3175 Make_Assignment_Statement (Loc, 3176 Name => New_Occurrence_Of (F, Loc), 3177 Expression => Get_Simple_Init_Val (Etype (F), Loc))); 3178 end if; 3179 3180 Next_Formal (F); 3181 end loop; 3182 3183 Validity_Checks_On := V; 3184 end; 3185 end if; 3186 3187 -- Clear out statement list for stubbed procedure 3188 3189 if Present (Corresponding_Spec (N)) then 3190 Set_Elaboration_Flag (N, Spec_Id); 3191 3192 if Convention (Spec_Id) = Convention_Stubbed 3193 or else Is_Eliminated (Spec_Id) 3194 then 3195 Set_Declarations (N, Empty_List); 3196 Set_Handled_Statement_Sequence (N, 3197 Make_Handled_Sequence_Of_Statements (Loc, 3198 Statements => New_List ( 3199 Make_Null_Statement (Loc)))); 3200 return; 3201 end if; 3202 end if; 3203 3204 Scop := Scope (Spec_Id); 3205 3206 -- Returns_By_Ref flag is normally set when the subprogram is frozen 3207 -- but subprograms with no specs are not frozen 3208 3209 declare 3210 Typ : constant Entity_Id := Etype (Spec_Id); 3211 Utyp : constant Entity_Id := Underlying_Type (Typ); 3212 3213 begin 3214 if not Acts_As_Spec (N) 3215 and then Nkind (Parent (Parent (Spec_Id))) /= 3216 N_Subprogram_Body_Stub 3217 then 3218 null; 3219 3220 elsif Is_Return_By_Reference_Type (Typ) then 3221 Set_Returns_By_Ref (Spec_Id); 3222 3223 elsif Present (Utyp) and then Controlled_Type (Utyp) then 3224 Set_Returns_By_Ref (Spec_Id); 3225 end if; 3226 end; 3227 3228 -- For a procedure, we add a return for all possible syntactic ends 3229 -- of the subprogram. Note that reanalysis is not necessary in this 3230 -- case since it would require a lot of work and accomplish nothing. 3231 3232 if Ekind (Spec_Id) = E_Procedure 3233 or else Ekind (Spec_Id) = E_Generic_Procedure 3234 then 3235 Add_Return (Statements (H)); 3236 3237 if Present (Exception_Handlers (H)) then 3238 Except_H := First_Non_Pragma (Exception_Handlers (H)); 3239 3240 while Present (Except_H) loop 3241 Add_Return (Statements (Except_H)); 3242 Next_Non_Pragma (Except_H); 3243 end loop; 3244 end if; 3245 3246 -- For a function, we must deal with the case where there is at 3247 -- least one missing return. What we do is to wrap the entire body 3248 -- of the function in a block: 3249 3250 -- begin 3251 -- ... 3252 -- end; 3253 3254 -- becomes 3255 3256 -- begin 3257 -- begin 3258 -- ... 3259 -- end; 3260 3261 -- raise Program_Error; 3262 -- end; 3263 3264 -- This approach is necessary because the raise must be signalled 3265 -- to the caller, not handled by any local handler (RM 6.4(11)). 3266 3267 -- Note: we do not need to analyze the constructed sequence here, 3268 -- since it has no handler, and an attempt to analyze the handled 3269 -- statement sequence twice is risky in various ways (e.g. the 3270 -- issue of expanding cleanup actions twice). 3271 3272 elsif Has_Missing_Return (Spec_Id) then 3273 declare 3274 Hloc : constant Source_Ptr := Sloc (H); 3275 Blok : constant Node_Id := 3276 Make_Block_Statement (Hloc, 3277 Handled_Statement_Sequence => H); 3278 Rais : constant Node_Id := 3279 Make_Raise_Program_Error (Hloc, 3280 Reason => PE_Missing_Return); 3281 3282 begin 3283 Set_Handled_Statement_Sequence (N, 3284 Make_Handled_Sequence_Of_Statements (Hloc, 3285 Statements => New_List (Blok, Rais))); 3286 3287 New_Scope (Spec_Id); 3288 Analyze (Blok); 3289 Analyze (Rais); 3290 Pop_Scope; 3291 end; 3292 end if; 3293 3294 -- Add discriminal renamings to protected subprograms. 3295 -- Install new discriminals for expansion of the next 3296 -- subprogram of this protected type, if any. 3297 3298 if Is_List_Member (N) 3299 and then Present (Parent (List_Containing (N))) 3300 and then Nkind (Parent (List_Containing (N))) = N_Protected_Body 3301 then 3302 Add_Discriminal_Declarations 3303 (Declarations (N), Scop, Name_uObject, Loc); 3304 Add_Private_Declarations (Declarations (N), Scop, Name_uObject, Loc); 3305 3306 -- Associate privals and discriminals with the next protected 3307 -- operation body to be expanded. These are used to expand 3308 -- references to private data objects and discriminants, 3309 -- respectively. 3310 3311 Next_Op := Next_Protected_Operation (N); 3312 3313 if Present (Next_Op) then 3314 Dec := Parent (Base_Type (Scop)); 3315 Set_Privals (Dec, Next_Op, Loc); 3316 Set_Discriminals (Dec); 3317 end if; 3318 end if; 3319 3320 -- If subprogram contains a parameterless recursive call, then we may 3321 -- have an infinite recursion, so see if we can generate code to check 3322 -- for this possibility if storage checks are not suppressed. 3323 3324 if Ekind (Spec_Id) = E_Procedure 3325 and then Has_Recursive_Call (Spec_Id) 3326 and then not Storage_Checks_Suppressed (Spec_Id) 3327 then 3328 Detect_Infinite_Recursion (N, Spec_Id); 3329 end if; 3330 3331 -- Finally, if we are in Normalize_Scalars mode, then any scalar out 3332 -- parameters must be initialized to the appropriate default value. 3333 3334 if Ekind (Spec_Id) = E_Procedure and then Normalize_Scalars then 3335 declare 3336 Floc : Source_Ptr; 3337 Formal : Entity_Id; 3338 Stm : Node_Id; 3339 3340 begin 3341 Formal := First_Formal (Spec_Id); 3342 3343 while Present (Formal) loop 3344 Floc := Sloc (Formal); 3345 3346 if Ekind (Formal) = E_Out_Parameter 3347 and then Is_Scalar_Type (Etype (Formal)) 3348 then 3349 Stm := 3350 Make_Assignment_Statement (Floc, 3351 Name => New_Occurrence_Of (Formal, Floc), 3352 Expression => 3353 Get_Simple_Init_Val (Etype (Formal), Floc)); 3354 Prepend (Stm, Declarations (N)); 3355 Analyze (Stm); 3356 end if; 3357 3358 Next_Formal (Formal); 3359 end loop; 3360 end; 3361 end if; 3362 3363 -- Deal with thread body 3364 3365 if Is_Thread_Body (Spec_Id) then 3366 Expand_Thread_Body; 3367 end if; 3368 3369 -- If the subprogram does not have pending instantiations, then we 3370 -- must generate the subprogram descriptor now, since the code for 3371 -- the subprogram is complete, and this is our last chance. However 3372 -- if there are pending instantiations, then the code is not 3373 -- complete, and we will delay the generation. 3374 3375 if Is_Subprogram (Spec_Id) 3376 and then not Delay_Subprogram_Descriptors (Spec_Id) 3377 then 3378 Generate_Subprogram_Descriptor_For_Subprogram (N, Spec_Id); 3379 end if; 3380 3381 -- Set to encode entity names in package body before gigi is called 3382 3383 Qualify_Entity_Names (N); 3384 end Expand_N_Subprogram_Body; 3385 3386 ----------------------------------- 3387 -- Expand_N_Subprogram_Body_Stub -- 3388 ----------------------------------- 3389 3390 procedure Expand_N_Subprogram_Body_Stub (N : Node_Id) is 3391 begin 3392 if Present (Corresponding_Body (N)) then 3393 Expand_N_Subprogram_Body ( 3394 Unit_Declaration_Node (Corresponding_Body (N))); 3395 end if; 3396 end Expand_N_Subprogram_Body_Stub; 3397 3398 ------------------------------------- 3399 -- Expand_N_Subprogram_Declaration -- 3400 ------------------------------------- 3401 3402 -- If the declaration appears within a protected body, it is a private 3403 -- operation of the protected type. We must create the corresponding 3404 -- protected subprogram an associated formals. For a normal protected 3405 -- operation, this is done when expanding the protected type declaration. 3406 3407 procedure Expand_N_Subprogram_Declaration (N : Node_Id) is 3408 Loc : constant Source_Ptr := Sloc (N); 3409 Subp : constant Entity_Id := Defining_Entity (N); 3410 Scop : constant Entity_Id := Scope (Subp); 3411 Prot_Decl : Node_Id; 3412 Prot_Bod : Node_Id; 3413 Prot_Id : Entity_Id; 3414 3415 begin 3416 -- Deal with case of protected subprogram 3417 3418 if Is_List_Member (N) 3419 and then Present (Parent (List_Containing (N))) 3420 and then Nkind (Parent (List_Containing (N))) = N_Protected_Body 3421 and then Is_Protected_Type (Scop) 3422 then 3423 if No (Protected_Body_Subprogram (Subp)) then 3424 Prot_Decl := 3425 Make_Subprogram_Declaration (Loc, 3426 Specification => 3427 Build_Protected_Sub_Specification 3428 (N, Scop, Unprotected => True)); 3429 3430 -- The protected subprogram is declared outside of the protected 3431 -- body. Given that the body has frozen all entities so far, we 3432 -- analyze the subprogram and perform freezing actions explicitly. 3433 -- If the body is a subunit, the insertion point is before the 3434 -- stub in the parent. 3435 3436 Prot_Bod := Parent (List_Containing (N)); 3437 3438 if Nkind (Parent (Prot_Bod)) = N_Subunit then 3439 Prot_Bod := Corresponding_Stub (Parent (Prot_Bod)); 3440 end if; 3441 3442 Insert_Before (Prot_Bod, Prot_Decl); 3443 Prot_Id := Defining_Unit_Name (Specification (Prot_Decl)); 3444 3445 New_Scope (Scope (Scop)); 3446 Analyze (Prot_Decl); 3447 Create_Extra_Formals (Prot_Id); 3448 Set_Protected_Body_Subprogram (Subp, Prot_Id); 3449 Pop_Scope; 3450 end if; 3451 end if; 3452 end Expand_N_Subprogram_Declaration; 3453 3454 --------------------------------------- 3455 -- Expand_Protected_Object_Reference -- 3456 --------------------------------------- 3457 3458 function Expand_Protected_Object_Reference 3459 (N : Node_Id; 3460 Scop : Entity_Id) 3461 return Node_Id 3462 is 3463 Loc : constant Source_Ptr := Sloc (N); 3464 Corr : Entity_Id; 3465 Rec : Node_Id; 3466 Param : Entity_Id; 3467 Proc : Entity_Id; 3468 3469 begin 3470 Rec := Make_Identifier (Loc, Name_uObject); 3471 Set_Etype (Rec, Corresponding_Record_Type (Scop)); 3472 3473 -- Find enclosing protected operation, and retrieve its first 3474 -- parameter, which denotes the enclosing protected object. 3475 -- If the enclosing operation is an entry, we are immediately 3476 -- within the protected body, and we can retrieve the object 3477 -- from the service entries procedure. A barrier function has 3478 -- has the same signature as an entry. A barrier function is 3479 -- compiled within the protected object, but unlike protected 3480 -- operations its never needs locks, so that its protected body 3481 -- subprogram points to itself. 3482 3483 Proc := Current_Scope; 3484 3485 while Present (Proc) 3486 and then Scope (Proc) /= Scop 3487 loop 3488 Proc := Scope (Proc); 3489 end loop; 3490 3491 Corr := Protected_Body_Subprogram (Proc); 3492 3493 if No (Corr) then 3494 3495 -- Previous error left expansion incomplete. 3496 -- Nothing to do on this call. 3497 3498 return Empty; 3499 end if; 3500 3501 Param := 3502 Defining_Identifier 3503 (First (Parameter_Specifications (Parent (Corr)))); 3504 3505 if Is_Subprogram (Proc) 3506 and then Proc /= Corr 3507 then 3508 -- Protected function or procedure. 3509 3510 Set_Entity (Rec, Param); 3511 3512 -- Rec is a reference to an entity which will not be in scope 3513 -- when the call is reanalyzed, and needs no further analysis. 3514 3515 Set_Analyzed (Rec); 3516 3517 else 3518 -- Entry or barrier function for entry body. 3519 -- The first parameter of the entry body procedure is a 3520 -- pointer to the object. We create a local variable 3521 -- of the proper type, duplicating what is done to define 3522 -- _object later on. 3523 3524 declare 3525 Decls : List_Id; 3526 Obj_Ptr : constant Entity_Id := Make_Defining_Identifier (Loc, 3527 Chars => 3528 New_Internal_Name ('T')); 3529 3530 begin 3531 Decls := New_List ( 3532 Make_Full_Type_Declaration (Loc, 3533 Defining_Identifier => Obj_Ptr, 3534 Type_Definition => 3535 Make_Access_To_Object_Definition (Loc, 3536 Subtype_Indication => 3537 New_Reference_To 3538 (Corresponding_Record_Type (Scop), Loc)))); 3539 3540 Insert_Actions (N, Decls); 3541 Insert_Actions (N, Freeze_Entity (Obj_Ptr, Sloc (N))); 3542 3543 Rec := 3544 Make_Explicit_Dereference (Loc, 3545 Unchecked_Convert_To (Obj_Ptr, 3546 New_Occurrence_Of (Param, Loc))); 3547 3548 -- Analyze new actual. Other actuals in calls are already 3549 -- analyzed and the list of actuals is not renalyzed after 3550 -- rewriting. 3551 3552 Set_Parent (Rec, N); 3553 Analyze (Rec); 3554 end; 3555 end if; 3556 3557 return Rec; 3558 end Expand_Protected_Object_Reference; 3559 3560 -------------------------------------- 3561 -- Expand_Protected_Subprogram_Call -- 3562 -------------------------------------- 3563 3564 procedure Expand_Protected_Subprogram_Call 3565 (N : Node_Id; 3566 Subp : Entity_Id; 3567 Scop : Entity_Id) 3568 is 3569 Rec : Node_Id; 3570 3571 begin 3572 -- If the protected object is not an enclosing scope, this is 3573 -- an inter-object function call. Inter-object procedure 3574 -- calls are expanded by Exp_Ch9.Build_Simple_Entry_Call. 3575 -- The call is intra-object only if the subprogram being 3576 -- called is in the protected body being compiled, and if the 3577 -- protected object in the call is statically the enclosing type. 3578 -- The object may be an component of some other data structure, 3579 -- in which case this must be handled as an inter-object call. 3580 3581 if not In_Open_Scopes (Scop) 3582 or else not Is_Entity_Name (Name (N)) 3583 then 3584 if Nkind (Name (N)) = N_Selected_Component then 3585 Rec := Prefix (Name (N)); 3586 3587 else 3588 pragma Assert (Nkind (Name (N)) = N_Indexed_Component); 3589 Rec := Prefix (Prefix (Name (N))); 3590 end if; 3591 3592 Build_Protected_Subprogram_Call (N, 3593 Name => New_Occurrence_Of (Subp, Sloc (N)), 3594 Rec => Convert_Concurrent (Rec, Etype (Rec)), 3595 External => True); 3596 3597 else 3598 Rec := Expand_Protected_Object_Reference (N, Scop); 3599 3600 if No (Rec) then 3601 return; 3602 end if; 3603 3604 Build_Protected_Subprogram_Call (N, 3605 Name => Name (N), 3606 Rec => Rec, 3607 External => False); 3608 3609 end if; 3610 3611 Analyze (N); 3612 3613 -- If it is a function call it can appear in elaboration code and 3614 -- the called entity must be frozen here. 3615 3616 if Ekind (Subp) = E_Function then 3617 Freeze_Expression (Name (N)); 3618 end if; 3619 end Expand_Protected_Subprogram_Call; 3620 3621 ----------------------- 3622 -- Freeze_Subprogram -- 3623 ----------------------- 3624 3625 procedure Freeze_Subprogram (N : Node_Id) is 3626 E : constant Entity_Id := Entity (N); 3627 3628 begin 3629 -- When a primitive is frozen, enter its name in the corresponding 3630 -- dispatch table. If the DTC_Entity field is not set this is an 3631 -- overridden primitive that can be ignored. We suppress the 3632 -- initialization of the dispatch table entry when Java_VM because 3633 -- the dispatching mechanism is handled internally by the JVM. 3634 3635 if Is_Dispatching_Operation (E) 3636 and then not Is_Abstract (E) 3637 and then Present (DTC_Entity (E)) 3638 and then not Is_CPP_Class (Scope (DTC_Entity (E))) 3639 and then not Java_VM 3640 then 3641 Check_Overriding_Operation (E); 3642 Insert_After (N, Fill_DT_Entry (Sloc (N), E)); 3643 end if; 3644 3645 -- Mark functions that return by reference. Note that it cannot be 3646 -- part of the normal semantic analysis of the spec since the 3647 -- underlying returned type may not be known yet (for private types) 3648 3649 declare 3650 Typ : constant Entity_Id := Etype (E); 3651 Utyp : constant Entity_Id := Underlying_Type (Typ); 3652 3653 begin 3654 if Is_Return_By_Reference_Type (Typ) then 3655 Set_Returns_By_Ref (E); 3656 3657 elsif Present (Utyp) and then Controlled_Type (Utyp) then 3658 Set_Returns_By_Ref (E); 3659 end if; 3660 end; 3661 end Freeze_Subprogram; 3662 3663end Exp_Ch6; 3664