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