1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- S E M _ D I S T -- 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 Casing; use Casing; 28with Einfo; use Einfo; 29with Errout; use Errout; 30with Exp_Dist; use Exp_Dist; 31with Exp_Tss; use Exp_Tss; 32with Nlists; use Nlists; 33with Nmake; use Nmake; 34with Namet; use Namet; 35with Opt; use Opt; 36with Rtsfind; use Rtsfind; 37with Sem; use Sem; 38with Sem_Aux; use Sem_Aux; 39with Sem_Disp; use Sem_Disp; 40with Sem_Eval; use Sem_Eval; 41with Sem_Res; use Sem_Res; 42with Sem_Util; use Sem_Util; 43with Sinfo; use Sinfo; 44with Stand; use Stand; 45with Stringt; use Stringt; 46with Tbuild; use Tbuild; 47with Uintp; use Uintp; 48 49package body Sem_Dist is 50 51 ----------------------- 52 -- Local Subprograms -- 53 ----------------------- 54 55 procedure RAS_E_Dereference (Pref : Node_Id); 56 -- Handles explicit dereference of Remote Access to Subprograms 57 58 function Full_Qualified_Name (E : Entity_Id) return String_Id; 59 -- returns the full qualified name of the entity in lower case 60 61 ------------------------- 62 -- Add_Stub_Constructs -- 63 ------------------------- 64 65 procedure Add_Stub_Constructs (N : Node_Id) is 66 U : constant Node_Id := Unit (N); 67 Spec : Entity_Id := Empty; 68 69 Exp : Node_Id := U; 70 -- Unit that will be expanded 71 72 begin 73 pragma Assert (Distribution_Stub_Mode /= No_Stubs); 74 75 if Nkind (U) = N_Package_Declaration then 76 Spec := Defining_Entity (Specification (U)); 77 78 elsif Nkind (U) = N_Package_Body then 79 Spec := Corresponding_Spec (U); 80 81 else pragma Assert (Nkind (U) = N_Package_Instantiation); 82 Exp := Instance_Spec (U); 83 Spec := Defining_Entity (Specification (Exp)); 84 end if; 85 86 pragma Assert (Is_Shared_Passive (Spec) 87 or else Is_Remote_Call_Interface (Spec)); 88 89 if Distribution_Stub_Mode = Generate_Caller_Stub_Body then 90 if Is_Shared_Passive (Spec) then 91 null; 92 elsif Nkind (U) = N_Package_Body then 93 Error_Msg_N 94 ("Specification file expected from command line", U); 95 else 96 Expand_Calling_Stubs_Bodies (Exp); 97 end if; 98 99 else 100 if Is_Shared_Passive (Spec) then 101 Build_Passive_Partition_Stub (Exp); 102 else 103 Expand_Receiving_Stubs_Bodies (Exp); 104 end if; 105 106 end if; 107 end Add_Stub_Constructs; 108 109 --------------------------------------- 110 -- Build_RAS_Primitive_Specification -- 111 --------------------------------------- 112 113 function Build_RAS_Primitive_Specification 114 (Subp_Spec : Node_Id; 115 Remote_Object_Type : Node_Id) return Node_Id 116 is 117 Loc : constant Source_Ptr := Sloc (Subp_Spec); 118 119 Primitive_Spec : constant Node_Id := 120 Copy_Specification (Loc, 121 Spec => Subp_Spec, 122 New_Name => Name_uCall); 123 124 Subtype_Mark_For_Self : Node_Id; 125 126 begin 127 if No (Parameter_Specifications (Primitive_Spec)) then 128 Set_Parameter_Specifications (Primitive_Spec, New_List); 129 end if; 130 131 if Nkind (Remote_Object_Type) in N_Entity then 132 Subtype_Mark_For_Self := 133 New_Occurrence_Of (Remote_Object_Type, Loc); 134 else 135 Subtype_Mark_For_Self := Remote_Object_Type; 136 end if; 137 138 Prepend_To ( 139 Parameter_Specifications (Primitive_Spec), 140 Make_Parameter_Specification (Loc, 141 Defining_Identifier => 142 Make_Defining_Identifier (Loc, Name_uS), 143 Parameter_Type => 144 Make_Access_Definition (Loc, 145 Subtype_Mark => 146 Subtype_Mark_For_Self))); 147 148 -- Trick later semantic analysis into considering this operation as a 149 -- primitive (dispatching) operation of tagged type Obj_Type. 150 151 Set_Comes_From_Source ( 152 Defining_Unit_Name (Primitive_Spec), True); 153 154 return Primitive_Spec; 155 end Build_RAS_Primitive_Specification; 156 157 ------------------------- 158 -- Full_Qualified_Name -- 159 ------------------------- 160 161 function Full_Qualified_Name (E : Entity_Id) return String_Id is 162 Ent : Entity_Id := E; 163 Parent_Name : String_Id := No_String; 164 165 begin 166 -- Deals properly with child units 167 168 if Nkind (Ent) = N_Defining_Program_Unit_Name then 169 Ent := Defining_Identifier (Ent); 170 end if; 171 172 -- Compute recursively the qualification (only "Standard" has no scope) 173 174 if Present (Scope (Scope (Ent))) then 175 Parent_Name := Full_Qualified_Name (Scope (Ent)); 176 end if; 177 178 -- Every entity should have a name except some expanded blocks. Do not 179 -- bother about those. 180 181 if Chars (Ent) = No_Name then 182 return Parent_Name; 183 end if; 184 185 -- Add a period between Name and qualification 186 187 if Parent_Name /= No_String then 188 Start_String (Parent_Name); 189 Store_String_Char (Get_Char_Code ('.')); 190 else 191 Start_String; 192 end if; 193 194 -- Generates the entity name in upper case 195 196 Get_Name_String (Chars (Ent)); 197 Set_Casing (All_Lower_Case); 198 Store_String_Chars (Name_Buffer (1 .. Name_Len)); 199 return End_String; 200 end Full_Qualified_Name; 201 202 ------------------ 203 -- Get_PCS_Name -- 204 ------------------ 205 206 function Get_PCS_Name return PCS_Names is 207 begin 208 return 209 Chars (Entity (Expression (Parent (RTE (RE_DSA_Implementation))))); 210 end Get_PCS_Name; 211 212 --------------------- 213 -- Get_PCS_Version -- 214 --------------------- 215 216 function Get_PCS_Version return Int is 217 PCS_Version_Entity : Entity_Id; 218 PCS_Version : Int; 219 220 begin 221 if RTE_Available (RE_PCS_Version) then 222 PCS_Version_Entity := RTE (RE_PCS_Version); 223 pragma Assert (Ekind (PCS_Version_Entity) = E_Named_Integer); 224 PCS_Version := 225 UI_To_Int (Expr_Value (Constant_Value (PCS_Version_Entity))); 226 227 else 228 -- Case of System.Partition_Interface.PCS_Version not found: 229 -- return a null version. 230 231 PCS_Version := 0; 232 end if; 233 234 return PCS_Version; 235 end Get_PCS_Version; 236 237 ------------------------ 238 -- Is_All_Remote_Call -- 239 ------------------------ 240 241 function Is_All_Remote_Call (N : Node_Id) return Boolean is 242 Par : Node_Id; 243 244 begin 245 if Nkind (N) in N_Subprogram_Call 246 and then Nkind (Name (N)) in N_Has_Entity 247 and then Is_Remote_Call_Interface (Entity (Name (N))) 248 and then Has_All_Calls_Remote (Scope (Entity (Name (N)))) 249 and then Comes_From_Source (N) 250 then 251 Par := Parent (Entity (Name (N))); 252 while Present (Par) 253 and then (Nkind (Par) /= N_Package_Specification 254 or else Is_Wrapper_Package (Defining_Entity (Par))) 255 loop 256 Par := Parent (Par); 257 end loop; 258 259 if Present (Par) then 260 return 261 not Scope_Within_Or_Same (Current_Scope, Defining_Entity (Par)); 262 else 263 return False; 264 end if; 265 else 266 return False; 267 end if; 268 end Is_All_Remote_Call; 269 270 --------------------------------- 271 -- Is_RACW_Stub_Type_Operation -- 272 --------------------------------- 273 274 function Is_RACW_Stub_Type_Operation (Op : Entity_Id) return Boolean is 275 Dispatching_Type : Entity_Id; 276 277 begin 278 case Ekind (Op) is 279 when E_Function | E_Procedure => 280 Dispatching_Type := Find_Dispatching_Type (Op); 281 return Present (Dispatching_Type) 282 and then Is_RACW_Stub_Type (Dispatching_Type) 283 and then not Is_Internal (Op); 284 285 when others => 286 return False; 287 end case; 288 end Is_RACW_Stub_Type_Operation; 289 290 --------------------------------- 291 -- Is_Valid_Remote_Object_Type -- 292 --------------------------------- 293 294 function Is_Valid_Remote_Object_Type (E : Entity_Id) return Boolean is 295 P : constant Node_Id := Parent (E); 296 297 begin 298 pragma Assert (Is_Tagged_Type (E)); 299 300 -- Simple case: a limited private type 301 302 if Nkind (P) = N_Private_Type_Declaration 303 and then Is_Limited_Record (E) 304 then 305 return True; 306 307 -- AI05-0060 (Binding Interpretation): A limited interface is a legal 308 -- ancestor for the designated type of an RACW type. 309 310 elsif Is_Limited_Record (E) and then Is_Limited_Interface (E) then 311 return True; 312 313 -- A generic tagged limited type is a valid candidate. Limitedness will 314 -- be checked again on the actual at instantiation point. 315 316 elsif Nkind (P) = N_Formal_Type_Declaration 317 and then Ekind (E) = E_Record_Type_With_Private 318 and then Is_Generic_Type (E) 319 and then Is_Limited_Record (E) 320 then 321 return True; 322 323 -- A private extension declaration is a valid candidate if its parent 324 -- type is. 325 326 elsif Nkind (P) = N_Private_Extension_Declaration then 327 return Is_Valid_Remote_Object_Type (Etype (E)); 328 329 else 330 return False; 331 end if; 332 end Is_Valid_Remote_Object_Type; 333 334 ------------------------------------ 335 -- Package_Specification_Of_Scope -- 336 ------------------------------------ 337 338 function Package_Specification_Of_Scope (E : Entity_Id) return Node_Id is 339 N : Node_Id; 340 341 begin 342 N := Parent (E); 343 while Nkind (N) /= N_Package_Specification loop 344 N := Parent (N); 345 end loop; 346 347 return N; 348 end Package_Specification_Of_Scope; 349 350 -------------------------- 351 -- Process_Partition_ID -- 352 -------------------------- 353 354 procedure Process_Partition_Id (N : Node_Id) is 355 Loc : constant Source_Ptr := Sloc (N); 356 Ety : Entity_Id; 357 Get_Pt_Id : Node_Id; 358 Get_Pt_Id_Call : Node_Id; 359 Prefix_String : String_Id; 360 Typ : constant Entity_Id := Etype (N); 361 362 begin 363 -- In case prefix is not a library unit entity, get the entity 364 -- of library unit. 365 366 Ety := Entity (Prefix (N)); 367 while (Present (Scope (Ety)) 368 and then Scope (Ety) /= Standard_Standard) 369 and not Is_Child_Unit (Ety) 370 loop 371 Ety := Scope (Ety); 372 end loop; 373 374 -- Retrieve the proper function to call 375 376 if Is_Remote_Call_Interface (Ety) then 377 Get_Pt_Id := New_Occurrence_Of 378 (RTE (RE_Get_Active_Partition_Id), Loc); 379 380 elsif Is_Shared_Passive (Ety) then 381 Get_Pt_Id := New_Occurrence_Of 382 (RTE (RE_Get_Passive_Partition_Id), Loc); 383 384 else 385 Get_Pt_Id := New_Occurrence_Of 386 (RTE (RE_Get_Local_Partition_Id), Loc); 387 end if; 388 389 -- Get and store the String_Id corresponding to the name of the 390 -- library unit whose Partition_Id is needed. 391 392 Get_Library_Unit_Name_String (Unit_Declaration_Node (Ety)); 393 Prefix_String := String_From_Name_Buffer; 394 395 -- Build the function call which will replace the attribute 396 397 if Is_Remote_Call_Interface (Ety) or else Is_Shared_Passive (Ety) then 398 Get_Pt_Id_Call := 399 Make_Function_Call (Loc, 400 Name => Get_Pt_Id, 401 Parameter_Associations => 402 New_List (Make_String_Literal (Loc, Prefix_String))); 403 404 else 405 Get_Pt_Id_Call := Make_Function_Call (Loc, Get_Pt_Id); 406 end if; 407 408 -- Replace the attribute node by a conversion of the function call 409 -- to the target type. 410 411 Rewrite (N, Convert_To (Typ, Get_Pt_Id_Call)); 412 Analyze_And_Resolve (N, Typ); 413 end Process_Partition_Id; 414 415 ---------------------------------- 416 -- Process_Remote_AST_Attribute -- 417 ---------------------------------- 418 419 procedure Process_Remote_AST_Attribute 420 (N : Node_Id; 421 New_Type : Entity_Id) 422 is 423 Loc : constant Source_Ptr := Sloc (N); 424 Remote_Subp : Entity_Id; 425 Tick_Access_Conv_Call : Node_Id; 426 Remote_Subp_Decl : Node_Id; 427 RS_Pkg_Specif : Node_Id; 428 RS_Pkg_E : Entity_Id; 429 RAS_Type : Entity_Id := New_Type; 430 Async_E : Entity_Id; 431 All_Calls_Remote_E : Entity_Id; 432 Attribute_Subp : Entity_Id; 433 434 begin 435 -- Check if we have to expand the access attribute 436 437 Remote_Subp := Entity (Prefix (N)); 438 439 if not Expander_Active or else Get_PCS_Name = Name_No_DSA then 440 return; 441 end if; 442 443 if Ekind (RAS_Type) /= E_Record_Type then 444 RAS_Type := Equivalent_Type (RAS_Type); 445 end if; 446 447 Attribute_Subp := TSS (RAS_Type, TSS_RAS_Access); 448 pragma Assert (Present (Attribute_Subp)); 449 Remote_Subp_Decl := Unit_Declaration_Node (Remote_Subp); 450 451 if Nkind (Remote_Subp_Decl) = N_Subprogram_Body then 452 Remote_Subp := Corresponding_Spec (Remote_Subp_Decl); 453 Remote_Subp_Decl := Unit_Declaration_Node (Remote_Subp); 454 end if; 455 456 RS_Pkg_Specif := Parent (Remote_Subp_Decl); 457 RS_Pkg_E := Defining_Entity (RS_Pkg_Specif); 458 459 Async_E := 460 Boolean_Literals (Ekind (Remote_Subp) = E_Procedure 461 and then Is_Asynchronous (Remote_Subp)); 462 463 All_Calls_Remote_E := 464 Boolean_Literals (Has_All_Calls_Remote (RS_Pkg_E)); 465 466 Tick_Access_Conv_Call := 467 Make_Function_Call (Loc, 468 Name => New_Occurrence_Of (Attribute_Subp, Loc), 469 Parameter_Associations => 470 New_List ( 471 Make_String_Literal (Loc, 472 Strval => Full_Qualified_Name (RS_Pkg_E)), 473 Build_Subprogram_Id (Loc, Remote_Subp), 474 New_Occurrence_Of (Async_E, Loc), 475 New_Occurrence_Of (All_Calls_Remote_E, Loc))); 476 477 Rewrite (N, Tick_Access_Conv_Call); 478 Analyze_And_Resolve (N, RAS_Type); 479 end Process_Remote_AST_Attribute; 480 481 ------------------------------------ 482 -- Process_Remote_AST_Declaration -- 483 ------------------------------------ 484 485 procedure Process_Remote_AST_Declaration (N : Node_Id) is 486 Loc : constant Source_Ptr := Sloc (N); 487 User_Type : constant Node_Id := Defining_Identifier (N); 488 Scop : constant Entity_Id := Scope (User_Type); 489 Is_RCI : constant Boolean := Is_Remote_Call_Interface (Scop); 490 Is_RT : constant Boolean := Is_Remote_Types (Scop); 491 Type_Def : constant Node_Id := Type_Definition (N); 492 Parameter : Node_Id; 493 494 Is_Degenerate : Boolean; 495 -- True iff this RAS has an access formal parameter (see 496 -- Exp_Dist.Add_RAS_Dereference_TSS for details). 497 498 Subpkg : constant Entity_Id := Make_Temporary (Loc, 'S'); 499 Subpkg_Decl : Node_Id; 500 Subpkg_Body : Node_Id; 501 Vis_Decls : constant List_Id := New_List; 502 Priv_Decls : constant List_Id := New_List; 503 504 Obj_Type : constant Entity_Id := 505 Make_Defining_Identifier (Loc, 506 New_External_Name (Chars (User_Type), 'R')); 507 508 Full_Obj_Type : constant Entity_Id := 509 Make_Defining_Identifier (Loc, Chars (Obj_Type)); 510 511 RACW_Type : constant Entity_Id := 512 Make_Defining_Identifier (Loc, 513 New_External_Name (Chars (User_Type), 'P')); 514 515 Fat_Type : constant Entity_Id := 516 Make_Defining_Identifier (Loc, Chars (User_Type)); 517 518 Fat_Type_Decl : Node_Id; 519 520 begin 521 Is_Degenerate := False; 522 Parameter := First (Parameter_Specifications (Type_Def)); 523 while Present (Parameter) loop 524 if Nkind (Parameter_Type (Parameter)) = N_Access_Definition then 525 Error_Msg_N 526 ("formal parameter& has anonymous access type??", 527 Defining_Identifier (Parameter)); 528 Is_Degenerate := True; 529 exit; 530 end if; 531 532 Next (Parameter); 533 end loop; 534 535 if Is_Degenerate then 536 Error_Msg_NE 537 ("remote access-to-subprogram type& can only be null??", 538 Defining_Identifier (Parameter), User_Type); 539 540 -- The only legal value for a RAS with a formal parameter of an 541 -- anonymous access type is null, because it cannot be subtype- 542 -- conformant with any legal remote subprogram declaration. In this 543 -- case, we cannot generate a corresponding primitive operation. 544 545 end if; 546 547 if Get_PCS_Name = Name_No_DSA then 548 return; 549 end if; 550 551 -- The tagged private type, primitive operation and RACW type associated 552 -- with a RAS need to all be declared in a subpackage of the one that 553 -- contains the RAS declaration, because the primitive of the object 554 -- type, and the associated primitive of the stub type, need to be 555 -- dispatching operations of these types, and the profile of the RAS 556 -- might contain tagged types declared in the same scope. 557 558 Append_To (Vis_Decls, 559 Make_Private_Type_Declaration (Loc, 560 Defining_Identifier => Obj_Type, 561 Abstract_Present => True, 562 Tagged_Present => True, 563 Limited_Present => True)); 564 565 Append_To (Priv_Decls, 566 Make_Full_Type_Declaration (Loc, 567 Defining_Identifier => Full_Obj_Type, 568 Type_Definition => 569 Make_Record_Definition (Loc, 570 Abstract_Present => True, 571 Tagged_Present => True, 572 Limited_Present => True, 573 Null_Present => True, 574 Component_List => Empty))); 575 576 -- Trick semantic analysis into swapping the public and full view when 577 -- freezing the public view. 578 579 Set_Comes_From_Source (Full_Obj_Type, True); 580 581 if not Is_Degenerate then 582 Append_To (Vis_Decls, 583 Make_Abstract_Subprogram_Declaration (Loc, 584 Specification => Build_RAS_Primitive_Specification ( 585 Subp_Spec => Type_Def, 586 Remote_Object_Type => Obj_Type))); 587 end if; 588 589 Append_To (Vis_Decls, 590 Make_Full_Type_Declaration (Loc, 591 Defining_Identifier => RACW_Type, 592 Type_Definition => 593 Make_Access_To_Object_Definition (Loc, 594 All_Present => True, 595 Subtype_Indication => 596 Make_Attribute_Reference (Loc, 597 Prefix => New_Occurrence_Of (Obj_Type, Loc), 598 Attribute_Name => Name_Class)))); 599 600 Set_Is_Remote_Call_Interface (RACW_Type, Is_RCI); 601 Set_Is_Remote_Types (RACW_Type, Is_RT); 602 603 Subpkg_Decl := 604 Make_Package_Declaration (Loc, 605 Make_Package_Specification (Loc, 606 Defining_Unit_Name => Subpkg, 607 Visible_Declarations => Vis_Decls, 608 Private_Declarations => Priv_Decls, 609 End_Label => New_Occurrence_Of (Subpkg, Loc))); 610 611 Set_Is_Remote_Call_Interface (Subpkg, Is_RCI); 612 Set_Is_Remote_Types (Subpkg, Is_RT); 613 Insert_After_And_Analyze (N, Subpkg_Decl); 614 615 -- Generate package body to receive RACW calling stubs 616 617 -- Note: Analyze_Declarations has an absolute requirement that the 618 -- declaration list be non-empty, so provide dummy null statement here. 619 620 Subpkg_Body := 621 Make_Package_Body (Loc, 622 Defining_Unit_Name => Make_Defining_Identifier (Loc, Chars (Subpkg)), 623 Declarations => New_List (Make_Null_Statement (Loc))); 624 Insert_After_And_Analyze (Subpkg_Decl, Subpkg_Body); 625 626 -- Many parts of the analyzer and expander expect 627 -- that the fat pointer type used to implement remote 628 -- access to subprogram types be a record. 629 -- Note: The structure of this type must be kept consistent 630 -- with the code generated by Remote_AST_Null_Value for the 631 -- corresponding 'null' expression. 632 633 Fat_Type_Decl := Make_Full_Type_Declaration (Loc, 634 Defining_Identifier => Fat_Type, 635 Type_Definition => 636 Make_Record_Definition (Loc, 637 Component_List => 638 Make_Component_List (Loc, 639 Component_Items => New_List ( 640 Make_Component_Declaration (Loc, 641 Defining_Identifier => 642 Make_Defining_Identifier (Loc, Name_Ras), 643 Component_Definition => 644 Make_Component_Definition (Loc, 645 Aliased_Present => False, 646 Subtype_Indication => 647 New_Occurrence_Of (RACW_Type, Loc))))))); 648 649 Set_Equivalent_Type (User_Type, Fat_Type); 650 Set_Corresponding_Remote_Type (Fat_Type, User_Type); 651 Insert_After_And_Analyze (Subpkg_Body, Fat_Type_Decl); 652 653 -- The reason we suppress the initialization procedure is that we know 654 -- that no initialization is required (even if Initialize_Scalars mode 655 -- is active), and there are order of elaboration problems if we do try 656 -- to generate an init proc for this created record type. 657 658 Set_Suppress_Initialization (Fat_Type); 659 660 if Expander_Active then 661 Add_RAST_Features (Parent (User_Type)); 662 end if; 663 end Process_Remote_AST_Declaration; 664 665 ----------------------- 666 -- RAS_E_Dereference -- 667 ----------------------- 668 669 procedure RAS_E_Dereference (Pref : Node_Id) is 670 Loc : constant Source_Ptr := Sloc (Pref); 671 Call_Node : Node_Id; 672 New_Type : constant Entity_Id := Etype (Pref); 673 Explicit_Deref : constant Node_Id := Parent (Pref); 674 Deref_Subp_Call : constant Node_Id := Parent (Explicit_Deref); 675 Deref_Proc : Entity_Id; 676 Params : List_Id; 677 678 begin 679 if Nkind (Deref_Subp_Call) = N_Procedure_Call_Statement then 680 Params := Parameter_Associations (Deref_Subp_Call); 681 682 if Present (Params) then 683 Prepend (Pref, Params); 684 else 685 Params := New_List (Pref); 686 end if; 687 688 elsif Nkind (Deref_Subp_Call) = N_Indexed_Component then 689 Params := Expressions (Deref_Subp_Call); 690 691 if Present (Params) then 692 Prepend (Pref, Params); 693 else 694 Params := New_List (Pref); 695 end if; 696 697 else 698 -- Context is not a call 699 700 return; 701 end if; 702 703 if not Expander_Active or else Get_PCS_Name = Name_No_DSA then 704 return; 705 end if; 706 707 Deref_Proc := TSS (New_Type, TSS_RAS_Dereference); 708 pragma Assert (Present (Deref_Proc)); 709 710 if Ekind (Deref_Proc) = E_Function then 711 Call_Node := 712 Make_Function_Call (Loc, 713 Name => New_Occurrence_Of (Deref_Proc, Loc), 714 Parameter_Associations => Params); 715 else 716 Call_Node := 717 Make_Procedure_Call_Statement (Loc, 718 Name => New_Occurrence_Of (Deref_Proc, Loc), 719 Parameter_Associations => Params); 720 end if; 721 722 Rewrite (Deref_Subp_Call, Call_Node); 723 Analyze (Deref_Subp_Call); 724 end RAS_E_Dereference; 725 726 ------------------------------ 727 -- Remote_AST_E_Dereference -- 728 ------------------------------ 729 730 function Remote_AST_E_Dereference (P : Node_Id) return Boolean is 731 ET : constant Entity_Id := Etype (P); 732 733 begin 734 -- Perform the changes only on original dereferences, and only if 735 -- we are generating code. 736 737 if Comes_From_Source (P) 738 and then Is_Record_Type (ET) 739 and then (Is_Remote_Call_Interface (ET) 740 or else Is_Remote_Types (ET)) 741 and then Present (Corresponding_Remote_Type (ET)) 742 and then Nkind_In (Parent (Parent (P)), N_Procedure_Call_Statement, 743 N_Indexed_Component) 744 and then Expander_Active 745 then 746 RAS_E_Dereference (P); 747 return True; 748 else 749 return False; 750 end if; 751 end Remote_AST_E_Dereference; 752 753 ------------------------------ 754 -- Remote_AST_I_Dereference -- 755 ------------------------------ 756 757 function Remote_AST_I_Dereference (P : Node_Id) return Boolean is 758 ET : constant Entity_Id := Etype (P); 759 Deref : Node_Id; 760 761 begin 762 if Comes_From_Source (P) 763 and then (Is_Remote_Call_Interface (ET) 764 or else Is_Remote_Types (ET)) 765 and then Present (Corresponding_Remote_Type (ET)) 766 and then Ekind (Entity (P)) /= E_Function 767 then 768 Deref := 769 Make_Explicit_Dereference (Sloc (P), 770 Prefix => Relocate_Node (P)); 771 Rewrite (P, Deref); 772 Set_Etype (P, ET); 773 RAS_E_Dereference (Prefix (P)); 774 return True; 775 end if; 776 777 return False; 778 end Remote_AST_I_Dereference; 779 780 --------------------------- 781 -- Remote_AST_Null_Value -- 782 --------------------------- 783 784 function Remote_AST_Null_Value 785 (N : Node_Id; 786 Typ : Entity_Id) return Boolean 787 is 788 Loc : constant Source_Ptr := Sloc (N); 789 Target_Type : Entity_Id; 790 791 begin 792 if not Expander_Active or else Get_PCS_Name = Name_No_DSA then 793 return False; 794 795 elsif Ekind (Typ) = E_Access_Subprogram_Type 796 and then (Is_Remote_Call_Interface (Typ) 797 or else Is_Remote_Types (Typ)) 798 and then Comes_From_Source (N) 799 and then Expander_Active 800 then 801 -- Any null that comes from source and is of the RAS type must 802 -- be expanded, except if expansion is not active (nothing 803 -- gets expanded into the equivalent record type). 804 805 Target_Type := Equivalent_Type (Typ); 806 807 elsif Ekind (Typ) = E_Record_Type 808 and then Present (Corresponding_Remote_Type (Typ)) 809 then 810 -- This is a record type representing a RAS type, this must be 811 -- expanded. 812 813 Target_Type := Typ; 814 815 else 816 -- We do not have to handle this case 817 818 return False; 819 end if; 820 821 Rewrite (N, 822 Make_Aggregate (Loc, 823 Component_Associations => New_List ( 824 Make_Component_Association (Loc, 825 Choices => New_List (Make_Identifier (Loc, Name_Ras)), 826 Expression => Make_Null (Loc))))); 827 Analyze_And_Resolve (N, Target_Type); 828 return True; 829 end Remote_AST_Null_Value; 830 831end Sem_Dist; 832