1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- E X P _ C H 2 -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING3. If not, go to -- 19-- http://www.gnu.org/licenses for a complete copy of the license. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 26with Atree; use Atree; 27with Checks; use Checks; 28with Debug; use Debug; 29with Einfo; use Einfo; 30with Elists; use Elists; 31with Exp_Smem; use Exp_Smem; 32with Exp_Tss; use Exp_Tss; 33with Exp_Util; use Exp_Util; 34with Namet; use Namet; 35with Nmake; use Nmake; 36with Opt; use Opt; 37with Output; use Output; 38with Sem; use Sem; 39with Sem_Eval; use Sem_Eval; 40with Sem_Res; use Sem_Res; 41with Sem_Util; use Sem_Util; 42with Sem_Warn; use Sem_Warn; 43with Sinfo; use Sinfo; 44with Sinput; use Sinput; 45with Snames; use Snames; 46with Tbuild; use Tbuild; 47 48package body Exp_Ch2 is 49 50 ----------------------- 51 -- Local Subprograms -- 52 ----------------------- 53 54 procedure Expand_Current_Value (N : Node_Id); 55 -- N is a node for a variable whose Current_Value field is set. If N is 56 -- node is for a discrete type, replaces node with a copy of the referenced 57 -- value. This provides a limited form of value propagation for variables 58 -- which are initialized or assigned not been further modified at the time 59 -- of reference. The call has no effect if the Current_Value refers to a 60 -- conditional with condition other than equality. 61 62 procedure Expand_Discriminant (N : Node_Id); 63 -- An occurrence of a discriminant within a discriminated type is replaced 64 -- with the corresponding discriminal, that is to say the formal parameter 65 -- of the initialization procedure for the type that is associated with 66 -- that particular discriminant. This replacement is not performed for 67 -- discriminants of records that appear in constraints of component of the 68 -- record, because Gigi uses the discriminant name to retrieve its value. 69 -- In the other hand, it has to be performed for default expressions of 70 -- components because they are used in the record init procedure. See Einfo 71 -- for more details, and Exp_Ch3, Exp_Ch9 for examples of use. For 72 -- discriminants of tasks and protected types, the transformation is more 73 -- complex when it occurs within a default expression for an entry or 74 -- protected operation. The corresponding default_expression_function has 75 -- an additional parameter which is the target of an entry call, and the 76 -- discriminant of the task must be replaced with a reference to the 77 -- discriminant of that formal parameter. 78 79 procedure Expand_Entity_Reference (N : Node_Id); 80 -- Common processing for expansion of identifiers and expanded names 81 -- Dispatches to specific expansion procedures. 82 83 procedure Expand_Entry_Index_Parameter (N : Node_Id); 84 -- A reference to the identifier in the entry index specification of an 85 -- entry body is modified to a reference to a constant definition equal to 86 -- the index of the entry family member being called. This constant is 87 -- calculated as part of the elaboration of the expanded code for the body, 88 -- and is calculated from the object-wide entry index returned by Next_ 89 -- Entry_Call. 90 91 procedure Expand_Entry_Parameter (N : Node_Id); 92 -- A reference to an entry parameter is modified to be a reference to the 93 -- corresponding component of the entry parameter record that is passed by 94 -- the runtime to the accept body procedure. 95 96 procedure Expand_Formal (N : Node_Id); 97 -- A reference to a formal parameter of a protected subprogram is expanded 98 -- into the corresponding formal of the unprotected procedure used to 99 -- represent the operation within the protected object. In other cases 100 -- Expand_Formal is a no-op. 101 102 procedure Expand_Protected_Component (N : Node_Id); 103 -- A reference to a private component of a protected type is expanded into 104 -- a reference to the corresponding prival in the current protected entry 105 -- or subprogram. 106 107 procedure Expand_Renaming (N : Node_Id); 108 -- For renamings, just replace the identifier by the corresponding 109 -- named expression. Note that this has been evaluated (see routine 110 -- Exp_Ch8.Expand_N_Object_Renaming.Evaluate_Name) so this gives 111 -- the correct renaming semantics. 112 113 -------------------------- 114 -- Expand_Current_Value -- 115 -------------------------- 116 117 procedure Expand_Current_Value (N : Node_Id) is 118 Loc : constant Source_Ptr := Sloc (N); 119 E : constant Entity_Id := Entity (N); 120 CV : constant Node_Id := Current_Value (E); 121 T : constant Entity_Id := Etype (N); 122 Val : Node_Id; 123 Op : Node_Kind; 124 125 -- Start of processing for Expand_Current_Value 126 127 begin 128 if True 129 130 -- No replacement if value raises constraint error 131 132 and then Nkind (CV) /= N_Raise_Constraint_Error 133 134 -- Do this only for discrete types 135 136 and then Is_Discrete_Type (T) 137 138 -- Do not replace biased types, since it is problematic to 139 -- consistently generate a sensible constant value in this case. 140 141 and then not Has_Biased_Representation (T) 142 143 -- Do not replace lvalues 144 145 and then not May_Be_Lvalue (N) 146 147 -- Check that entity is suitable for replacement 148 149 and then OK_To_Do_Constant_Replacement (E) 150 151 -- Do not replace occurrences in pragmas (where names typically 152 -- appear not as values, but as simply names. If there are cases 153 -- where values are required, it is only a very minor efficiency 154 -- issue that they do not get replaced when they could be). 155 156 and then Nkind (Parent (N)) /= N_Pragma_Argument_Association 157 158 -- Do not replace the prefixes of attribute references, since this 159 -- causes trouble with cases like 4'Size. Also for Name_Asm_Input and 160 -- Name_Asm_Output, don't do replacement anywhere, since we can have 161 -- lvalue references in the arguments. 162 163 and then not (Nkind (Parent (N)) = N_Attribute_Reference 164 and then 165 (Nam_In (Attribute_Name (Parent (N)), 166 Name_Asm_Input, 167 Name_Asm_Output) 168 or else Prefix (Parent (N)) = N)) 169 170 then 171 -- Case of Current_Value is a compile time known value 172 173 if Nkind (CV) in N_Subexpr then 174 Val := CV; 175 176 -- Case of Current_Value is an if expression reference 177 178 else 179 Get_Current_Value_Condition (N, Op, Val); 180 181 if Op /= N_Op_Eq then 182 return; 183 end if; 184 end if; 185 186 -- If constant value is an occurrence of an enumeration literal, 187 -- then we just make another occurrence of the same literal. 188 189 if Is_Entity_Name (Val) 190 and then Ekind (Entity (Val)) = E_Enumeration_Literal 191 then 192 Rewrite (N, 193 Unchecked_Convert_To (T, 194 New_Occurrence_Of (Entity (Val), Loc))); 195 196 -- If constant is of an integer type, just make an appropriately 197 -- integer literal, which will get the proper type. 198 199 elsif Is_Integer_Type (T) then 200 Rewrite (N, 201 Make_Integer_Literal (Loc, 202 Intval => Expr_Rep_Value (Val))); 203 204 -- Otherwise do unchecked conversion of value to right type 205 206 else 207 Rewrite (N, 208 Unchecked_Convert_To (T, 209 Make_Integer_Literal (Loc, 210 Intval => Expr_Rep_Value (Val)))); 211 end if; 212 213 Analyze_And_Resolve (N, T); 214 Set_Is_Static_Expression (N, False); 215 end if; 216 end Expand_Current_Value; 217 218 ------------------------- 219 -- Expand_Discriminant -- 220 ------------------------- 221 222 procedure Expand_Discriminant (N : Node_Id) is 223 Scop : constant Entity_Id := Scope (Entity (N)); 224 P : Node_Id := N; 225 Parent_P : Node_Id := Parent (P); 226 In_Entry : Boolean := False; 227 228 begin 229 -- The Incomplete_Or_Private_Kind happens while resolving the 230 -- discriminant constraint involved in a derived full type, 231 -- such as: 232 233 -- type D is private; 234 -- type D(C : ...) is new T(C); 235 236 if Ekind (Scop) = E_Record_Type 237 or Ekind (Scop) in Incomplete_Or_Private_Kind 238 then 239 -- Find the origin by walking up the tree till the component 240 -- declaration 241 242 while Present (Parent_P) 243 and then Nkind (Parent_P) /= N_Component_Declaration 244 loop 245 P := Parent_P; 246 Parent_P := Parent (P); 247 end loop; 248 249 -- If the discriminant reference was part of the default expression 250 -- it has to be "discriminalized" 251 252 if Present (Parent_P) and then P = Expression (Parent_P) then 253 Set_Entity (N, Discriminal (Entity (N))); 254 end if; 255 256 elsif Is_Concurrent_Type (Scop) then 257 while Present (Parent_P) 258 and then Nkind (Parent_P) /= N_Subprogram_Body 259 loop 260 P := Parent_P; 261 262 if Nkind (P) = N_Entry_Declaration then 263 In_Entry := True; 264 end if; 265 266 Parent_P := Parent (Parent_P); 267 end loop; 268 269 -- If the discriminant occurs within the default expression for a 270 -- formal of an entry or protected operation, replace it with a 271 -- reference to the discriminant of the formal of the enclosing 272 -- operation. 273 274 if Present (Parent_P) 275 and then Present (Corresponding_Spec (Parent_P)) 276 then 277 declare 278 Loc : constant Source_Ptr := Sloc (N); 279 D_Fun : constant Entity_Id := Corresponding_Spec (Parent_P); 280 Formal : constant Entity_Id := First_Formal (D_Fun); 281 New_N : Node_Id; 282 Disc : Entity_Id; 283 284 begin 285 -- Verify that we are within the body of an entry or protected 286 -- operation. Its first formal parameter is the synchronized 287 -- type itself. 288 289 if Present (Formal) 290 and then Etype (Formal) = Scope (Entity (N)) 291 then 292 Disc := CR_Discriminant (Entity (N)); 293 294 New_N := 295 Make_Selected_Component (Loc, 296 Prefix => New_Occurrence_Of (Formal, Loc), 297 Selector_Name => New_Occurrence_Of (Disc, Loc)); 298 299 Set_Etype (New_N, Etype (N)); 300 Rewrite (N, New_N); 301 302 else 303 Set_Entity (N, Discriminal (Entity (N))); 304 end if; 305 end; 306 307 elsif Nkind (Parent (N)) = N_Range 308 and then In_Entry 309 then 310 Set_Entity (N, CR_Discriminant (Entity (N))); 311 312 -- Finally, if the entity is the discriminant of the original 313 -- type declaration, and we are within the initialization 314 -- procedure for a task, the designated entity is the 315 -- discriminal of the task body. This can happen when the 316 -- argument of pragma Task_Name mentions a discriminant, 317 -- because the pragma is analyzed in the task declaration 318 -- but is expanded in the call to Create_Task in the init_proc. 319 320 elsif Within_Init_Proc then 321 Set_Entity (N, Discriminal (CR_Discriminant (Entity (N)))); 322 else 323 Set_Entity (N, Discriminal (Entity (N))); 324 end if; 325 326 else 327 Set_Entity (N, Discriminal (Entity (N))); 328 end if; 329 end Expand_Discriminant; 330 331 ----------------------------- 332 -- Expand_Entity_Reference -- 333 ----------------------------- 334 335 procedure Expand_Entity_Reference (N : Node_Id) is 336 E : constant Entity_Id := Entity (N); 337 338 begin 339 -- Defend against errors 340 341 if No (E) then 342 Check_Error_Detected; 343 return; 344 end if; 345 346 if Ekind (E) = E_Discriminant then 347 Expand_Discriminant (N); 348 349 elsif Is_Entry_Formal (E) then 350 Expand_Entry_Parameter (N); 351 352 elsif Is_Protected_Component (E) then 353 if No_Run_Time_Mode then 354 return; 355 else 356 Expand_Protected_Component (N); 357 end if; 358 359 elsif Ekind (E) = E_Entry_Index_Parameter then 360 Expand_Entry_Index_Parameter (N); 361 362 elsif Is_Formal (E) then 363 Expand_Formal (N); 364 365 elsif Is_Renaming_Of_Object (E) then 366 Expand_Renaming (N); 367 368 elsif Ekind (E) = E_Variable 369 and then Is_Shared_Passive (E) 370 then 371 Expand_Shared_Passive_Variable (N); 372 end if; 373 374 -- Test code for implementing the pragma Reviewable requirement of 375 -- classifying reads of scalars as referencing potentially uninitialized 376 -- objects or not. 377 378 if Debug_Flag_XX 379 and then Is_Scalar_Type (Etype (N)) 380 and then (Is_Assignable (E) or else Is_Constant_Object (E)) 381 and then Comes_From_Source (N) 382 and then Is_LHS (N) = No 383 and then not Is_Actual_Out_Parameter (N) 384 and then (Nkind (Parent (N)) /= N_Attribute_Reference 385 or else Attribute_Name (Parent (N)) /= Name_Valid) 386 then 387 Write_Location (Sloc (N)); 388 Write_Str (": Read from scalar """); 389 Write_Name (Chars (N)); 390 Write_Str (""""); 391 392 if Is_Known_Valid (E) then 393 Write_Str (", Is_Known_Valid"); 394 end if; 395 396 Write_Eol; 397 end if; 398 399 -- Set Atomic_Sync_Required if necessary for atomic variable 400 401 if Nkind_In (N, N_Identifier, N_Expanded_Name) 402 and then Ekind (E) = E_Variable 403 and then (Is_Atomic (E) or else Is_Atomic (Etype (E))) 404 then 405 declare 406 Set : Boolean; 407 408 begin 409 -- If variable is atomic, but type is not, setting depends on 410 -- disable/enable state for the variable. 411 412 if Is_Atomic (E) and then not Is_Atomic (Etype (E)) then 413 Set := not Atomic_Synchronization_Disabled (E); 414 415 -- If variable is not atomic, but its type is atomic, setting 416 -- depends on disable/enable state for the type. 417 418 elsif not Is_Atomic (E) and then Is_Atomic (Etype (E)) then 419 Set := not Atomic_Synchronization_Disabled (Etype (E)); 420 421 -- Else both variable and type are atomic (see outer if), and we 422 -- disable if either variable or its type have sync disabled. 423 424 else 425 Set := (not Atomic_Synchronization_Disabled (E)) 426 and then 427 (not Atomic_Synchronization_Disabled (Etype (E))); 428 end if; 429 430 -- Set flag if required 431 432 if Set then 433 Activate_Atomic_Synchronization (N); 434 end if; 435 end; 436 end if; 437 438 -- Interpret possible Current_Value for variable case 439 440 if Is_Assignable (E) 441 and then Present (Current_Value (E)) 442 then 443 Expand_Current_Value (N); 444 445 -- We do want to warn for the case of a boolean variable (not a 446 -- boolean constant) whose value is known at compile time. 447 448 if Is_Boolean_Type (Etype (N)) then 449 Warn_On_Known_Condition (N); 450 end if; 451 452 -- Don't mess with Current_Value for compile time known values. Not 453 -- only is it unnecessary, but we could disturb an indication of a 454 -- static value, which could cause semantic trouble. 455 456 elsif Compile_Time_Known_Value (N) then 457 null; 458 459 -- Interpret possible Current_Value for constant case 460 461 elsif Is_Constant_Object (E) 462 and then Present (Current_Value (E)) 463 then 464 Expand_Current_Value (N); 465 end if; 466 end Expand_Entity_Reference; 467 468 ---------------------------------- 469 -- Expand_Entry_Index_Parameter -- 470 ---------------------------------- 471 472 procedure Expand_Entry_Index_Parameter (N : Node_Id) is 473 Index_Con : constant Entity_Id := Entry_Index_Constant (Entity (N)); 474 begin 475 Set_Entity (N, Index_Con); 476 Set_Etype (N, Etype (Index_Con)); 477 end Expand_Entry_Index_Parameter; 478 479 ---------------------------- 480 -- Expand_Entry_Parameter -- 481 ---------------------------- 482 483 procedure Expand_Entry_Parameter (N : Node_Id) is 484 Loc : constant Source_Ptr := Sloc (N); 485 Ent_Formal : constant Entity_Id := Entity (N); 486 Ent_Spec : constant Entity_Id := Scope (Ent_Formal); 487 Parm_Type : constant Entity_Id := Entry_Parameters_Type (Ent_Spec); 488 Acc_Stack : constant Elist_Id := Accept_Address (Ent_Spec); 489 Addr_Ent : constant Entity_Id := Node (Last_Elmt (Acc_Stack)); 490 P_Comp_Ref : Entity_Id; 491 492 function In_Assignment_Context (N : Node_Id) return Boolean; 493 -- Check whether this is a context in which the entry formal may be 494 -- assigned to. 495 496 --------------------------- 497 -- In_Assignment_Context -- 498 --------------------------- 499 500 function In_Assignment_Context (N : Node_Id) return Boolean is 501 begin 502 -- Case of use in a call 503 504 -- ??? passing a formal as actual for a mode IN formal is 505 -- considered as an assignment? 506 507 if Nkind_In (Parent (N), N_Procedure_Call_Statement, 508 N_Entry_Call_Statement) 509 or else (Nkind (Parent (N)) = N_Assignment_Statement 510 and then N = Name (Parent (N))) 511 then 512 return True; 513 514 -- Case of a parameter association: climb up to enclosing call 515 516 elsif Nkind (Parent (N)) = N_Parameter_Association then 517 return In_Assignment_Context (Parent (N)); 518 519 -- Case of a selected component, indexed component or slice prefix: 520 -- climb up the tree, unless the prefix is of an access type (in 521 -- which case there is an implicit dereference, and the formal itself 522 -- is not being assigned to). 523 524 elsif Nkind_In (Parent (N), N_Selected_Component, 525 N_Indexed_Component, 526 N_Slice) 527 and then N = Prefix (Parent (N)) 528 and then not Is_Access_Type (Etype (N)) 529 and then In_Assignment_Context (Parent (N)) 530 then 531 return True; 532 533 else 534 return False; 535 end if; 536 end In_Assignment_Context; 537 538 -- Start of processing for Expand_Entry_Parameter 539 540 begin 541 if Is_Task_Type (Scope (Ent_Spec)) 542 and then Comes_From_Source (Ent_Formal) 543 then 544 -- Before replacing the formal with the local renaming that is used 545 -- in the accept block, note if this is an assignment context, and 546 -- note the modification to avoid spurious warnings, because the 547 -- original entity is not used further. If formal is unconstrained, 548 -- we also generate an extra parameter to hold the Constrained 549 -- attribute of the actual. No renaming is generated for this flag. 550 551 -- Calling Note_Possible_Modification in the expander is dubious, 552 -- because this generates a cross-reference entry, and should be 553 -- done during semantic processing so it is called in -gnatc mode??? 554 555 if Ekind (Entity (N)) /= E_In_Parameter 556 and then In_Assignment_Context (N) 557 then 558 Note_Possible_Modification (N, Sure => True); 559 end if; 560 end if; 561 562 -- What we need is a reference to the corresponding component of the 563 -- parameter record object. The Accept_Address field of the entry entity 564 -- references the address variable that contains the address of the 565 -- accept parameters record. We first have to do an unchecked conversion 566 -- to turn this into a pointer to the parameter record and then we 567 -- select the required parameter field. 568 569 -- The same processing applies to protected entries, where the Accept_ 570 -- Address is also the address of the Parameters record. 571 572 P_Comp_Ref := 573 Make_Selected_Component (Loc, 574 Prefix => 575 Make_Explicit_Dereference (Loc, 576 Unchecked_Convert_To (Parm_Type, 577 New_Occurrence_Of (Addr_Ent, Loc))), 578 Selector_Name => 579 New_Occurrence_Of (Entry_Component (Ent_Formal), Loc)); 580 581 -- For all types of parameters, the constructed parameter record object 582 -- contains a pointer to the parameter. Thus we must dereference them to 583 -- access them (this will often be redundant, since the dereference is 584 -- implicit, but no harm is done by making it explicit). 585 586 Rewrite (N, 587 Make_Explicit_Dereference (Loc, P_Comp_Ref)); 588 589 Analyze (N); 590 end Expand_Entry_Parameter; 591 592 ------------------- 593 -- Expand_Formal -- 594 ------------------- 595 596 procedure Expand_Formal (N : Node_Id) is 597 E : constant Entity_Id := Entity (N); 598 Scop : constant Entity_Id := Scope (E); 599 600 begin 601 -- Check whether the subprogram of which this is a formal is 602 -- a protected operation. The initialization procedure for 603 -- the corresponding record type is not itself a protected operation. 604 605 if Is_Protected_Type (Scope (Scop)) 606 and then not Is_Init_Proc (Scop) 607 and then Present (Protected_Formal (E)) 608 then 609 Set_Entity (N, Protected_Formal (E)); 610 end if; 611 end Expand_Formal; 612 613 ---------------------------- 614 -- Expand_N_Expanded_Name -- 615 ---------------------------- 616 617 procedure Expand_N_Expanded_Name (N : Node_Id) is 618 begin 619 Expand_Entity_Reference (N); 620 end Expand_N_Expanded_Name; 621 622 ------------------------- 623 -- Expand_N_Identifier -- 624 ------------------------- 625 626 procedure Expand_N_Identifier (N : Node_Id) is 627 begin 628 Expand_Entity_Reference (N); 629 end Expand_N_Identifier; 630 631 --------------------------- 632 -- Expand_N_Real_Literal -- 633 --------------------------- 634 635 procedure Expand_N_Real_Literal (N : Node_Id) is 636 pragma Unreferenced (N); 637 638 begin 639 -- Historically, this routine existed because there were expansion 640 -- requirements for Vax real literals, but now Vax real literals 641 -- are now handled by gigi, so this routine no longer does anything. 642 643 null; 644 end Expand_N_Real_Literal; 645 646 -------------------------------- 647 -- Expand_Protected_Component -- 648 -------------------------------- 649 650 procedure Expand_Protected_Component (N : Node_Id) is 651 652 function Inside_Eliminated_Body return Boolean; 653 -- Determine whether the current entity is inside a subprogram or an 654 -- entry which has been marked as eliminated. 655 656 ---------------------------- 657 -- Inside_Eliminated_Body -- 658 ---------------------------- 659 660 function Inside_Eliminated_Body return Boolean is 661 S : Entity_Id := Current_Scope; 662 663 begin 664 while Present (S) loop 665 if (Ekind (S) = E_Entry 666 or else Ekind (S) = E_Entry_Family 667 or else Ekind (S) = E_Function 668 or else Ekind (S) = E_Procedure) 669 and then Is_Eliminated (S) 670 then 671 return True; 672 end if; 673 674 S := Scope (S); 675 end loop; 676 677 return False; 678 end Inside_Eliminated_Body; 679 680 -- Start of processing for Expand_Protected_Component 681 682 begin 683 -- Eliminated bodies are not expanded and thus do not need privals 684 685 if not Inside_Eliminated_Body then 686 declare 687 Priv : constant Entity_Id := Prival (Entity (N)); 688 begin 689 Set_Entity (N, Priv); 690 Set_Etype (N, Etype (Priv)); 691 end; 692 end if; 693 end Expand_Protected_Component; 694 695 --------------------- 696 -- Expand_Renaming -- 697 --------------------- 698 699 procedure Expand_Renaming (N : Node_Id) is 700 E : constant Entity_Id := Entity (N); 701 T : constant Entity_Id := Etype (N); 702 703 begin 704 Rewrite (N, New_Copy_Tree (Renamed_Object (E))); 705 706 -- We mark the copy as unanalyzed, so that it is sure to be reanalyzed 707 -- at the top level. This is needed in the packed case since we 708 -- specifically avoided expanding packed array references when the 709 -- renaming declaration was analyzed. 710 711 Reset_Analyzed_Flags (N); 712 Analyze_And_Resolve (N, T); 713 end Expand_Renaming; 714 715 ------------------ 716 -- Param_Entity -- 717 ------------------ 718 719 -- This would be trivial, simply a test for an identifier that was a 720 -- reference to a formal, if it were not for the fact that a previous call 721 -- to Expand_Entry_Parameter will have modified the reference to the 722 -- identifier. A formal of a protected entity is rewritten as 723 724 -- typ!(recobj).rec.all'Constrained 725 726 -- where rec is a selector whose Entry_Formal link points to the formal 727 728 -- If the type of the entry parameter has a representation clause, then an 729 -- extra temp is involved (see below). 730 731 -- For a formal of a task entity, the formal is rewritten as a local 732 -- renaming. 733 734 -- In addition, a formal that is marked volatile because it is aliased 735 -- through an address clause is rewritten as dereference as well. 736 737 function Param_Entity (N : Node_Id) return Entity_Id is 738 Renamed_Obj : Node_Id; 739 740 begin 741 -- Simple reference case 742 743 if Nkind_In (N, N_Identifier, N_Expanded_Name) then 744 if Is_Formal (Entity (N)) then 745 return Entity (N); 746 747 -- Handle renamings of formal parameters and formals of tasks that 748 -- are rewritten as renamings. 749 750 elsif Nkind (Parent (Entity (N))) = N_Object_Renaming_Declaration then 751 Renamed_Obj := Get_Referenced_Object (Renamed_Object (Entity (N))); 752 753 if Is_Entity_Name (Renamed_Obj) 754 and then Is_Formal (Entity (Renamed_Obj)) 755 then 756 return Entity (Renamed_Obj); 757 758 elsif 759 Nkind (Parent (Parent (Entity (N)))) = N_Accept_Statement 760 then 761 return Entity (N); 762 end if; 763 end if; 764 765 else 766 if Nkind (N) = N_Explicit_Dereference then 767 declare 768 P : Node_Id := Prefix (N); 769 S : Node_Id; 770 E : Entity_Id; 771 Decl : Node_Id; 772 773 begin 774 -- If the type of an entry parameter has a representation 775 -- clause, then the prefix is not a selected component, but 776 -- instead a reference to a temp pointing at the selected 777 -- component. In this case, set P to be the initial value of 778 -- that temp. 779 780 if Nkind (P) = N_Identifier then 781 E := Entity (P); 782 783 if Ekind (E) = E_Constant then 784 Decl := Parent (E); 785 786 if Nkind (Decl) = N_Object_Declaration then 787 P := Expression (Decl); 788 end if; 789 end if; 790 end if; 791 792 if Nkind (P) = N_Selected_Component then 793 S := Selector_Name (P); 794 795 if Present (Entry_Formal (Entity (S))) then 796 return Entry_Formal (Entity (S)); 797 end if; 798 799 elsif Nkind (Original_Node (N)) = N_Identifier then 800 return Param_Entity (Original_Node (N)); 801 end if; 802 end; 803 end if; 804 end if; 805 806 return (Empty); 807 end Param_Entity; 808 809end Exp_Ch2; 810