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-2019, 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 Typ : Entity_Id; 276 277 begin 278 case Ekind (Op) is 279 when E_Function 280 | E_Procedure 281 => 282 Typ := Find_Dispatching_Type (Op); 283 284 return 285 Present (Typ) 286 and then Is_RACW_Stub_Type (Typ) 287 and then not Is_Internal (Op); 288 289 when others => 290 return False; 291 end case; 292 end Is_RACW_Stub_Type_Operation; 293 294 --------------------------------- 295 -- Is_Valid_Remote_Object_Type -- 296 --------------------------------- 297 298 function Is_Valid_Remote_Object_Type (E : Entity_Id) return Boolean is 299 P : constant Node_Id := Parent (E); 300 301 begin 302 pragma Assert (Is_Tagged_Type (E)); 303 304 -- Simple case: a limited private type 305 306 if Nkind (P) = N_Private_Type_Declaration 307 and then Is_Limited_Record (E) 308 then 309 return True; 310 311 -- AI05-0060 (Binding Interpretation): A limited interface is a legal 312 -- ancestor for the designated type of an RACW type. 313 314 elsif Is_Limited_Record (E) and then Is_Limited_Interface (E) then 315 return True; 316 317 -- A generic tagged limited type is a valid candidate. Limitedness will 318 -- be checked again on the actual at instantiation point. 319 320 elsif Nkind (P) = N_Formal_Type_Declaration 321 and then Ekind (E) = E_Record_Type_With_Private 322 and then Is_Generic_Type (E) 323 and then Is_Limited_Record (E) 324 then 325 return True; 326 327 -- A private extension declaration is a valid candidate if its parent 328 -- type is. 329 330 elsif Nkind (P) = N_Private_Extension_Declaration then 331 return Is_Valid_Remote_Object_Type (Etype (E)); 332 333 else 334 return False; 335 end if; 336 end Is_Valid_Remote_Object_Type; 337 338 ------------------------------------ 339 -- Package_Specification_Of_Scope -- 340 ------------------------------------ 341 342 function Package_Specification_Of_Scope (E : Entity_Id) return Node_Id is 343 N : Node_Id; 344 345 begin 346 N := Parent (E); 347 while Nkind (N) /= N_Package_Specification loop 348 N := Parent (N); 349 end loop; 350 351 return N; 352 end Package_Specification_Of_Scope; 353 354 -------------------------- 355 -- Process_Partition_Id -- 356 -------------------------- 357 358 procedure Process_Partition_Id (N : Node_Id) is 359 Loc : constant Source_Ptr := Sloc (N); 360 Ety : Entity_Id; 361 Get_Pt_Id : Node_Id; 362 Get_Pt_Id_Call : Node_Id; 363 Prefix_String : String_Id; 364 Typ : constant Entity_Id := Etype (N); 365 366 begin 367 -- In case prefix is not a library unit entity, get the entity 368 -- of library unit. 369 370 Ety := Entity (Prefix (N)); 371 while (Present (Scope (Ety)) 372 and then Scope (Ety) /= Standard_Standard) 373 and not Is_Child_Unit (Ety) 374 loop 375 Ety := Scope (Ety); 376 end loop; 377 378 -- Retrieve the proper function to call 379 380 if Is_Remote_Call_Interface (Ety) then 381 Get_Pt_Id := New_Occurrence_Of 382 (RTE (RE_Get_Active_Partition_Id), Loc); 383 384 elsif Is_Shared_Passive (Ety) then 385 Get_Pt_Id := New_Occurrence_Of 386 (RTE (RE_Get_Passive_Partition_Id), Loc); 387 388 else 389 Get_Pt_Id := New_Occurrence_Of 390 (RTE (RE_Get_Local_Partition_Id), Loc); 391 end if; 392 393 -- Get and store the String_Id corresponding to the name of the 394 -- library unit whose Partition_Id is needed. 395 396 Get_Library_Unit_Name_String (Unit_Declaration_Node (Ety)); 397 Prefix_String := String_From_Name_Buffer; 398 399 -- Build the function call which will replace the attribute 400 401 if Is_Remote_Call_Interface (Ety) or else Is_Shared_Passive (Ety) then 402 Get_Pt_Id_Call := 403 Make_Function_Call (Loc, 404 Name => Get_Pt_Id, 405 Parameter_Associations => 406 New_List (Make_String_Literal (Loc, Prefix_String))); 407 408 else 409 Get_Pt_Id_Call := Make_Function_Call (Loc, Get_Pt_Id); 410 end if; 411 412 -- Replace the attribute node by a conversion of the function call 413 -- to the target type. 414 415 Rewrite (N, Convert_To (Typ, Get_Pt_Id_Call)); 416 Analyze_And_Resolve (N, Typ); 417 end Process_Partition_Id; 418 419 ---------------------------------- 420 -- Process_Remote_AST_Attribute -- 421 ---------------------------------- 422 423 procedure Process_Remote_AST_Attribute 424 (N : Node_Id; 425 New_Type : Entity_Id) 426 is 427 Loc : constant Source_Ptr := Sloc (N); 428 Remote_Subp : Entity_Id; 429 Tick_Access_Conv_Call : Node_Id; 430 Remote_Subp_Decl : Node_Id; 431 RS_Pkg_Specif : Node_Id; 432 RS_Pkg_E : Entity_Id; 433 RAS_Type : Entity_Id := New_Type; 434 Async_E : Entity_Id; 435 All_Calls_Remote_E : Entity_Id; 436 Attribute_Subp : Entity_Id; 437 438 begin 439 -- Check if we have to expand the access attribute 440 441 Remote_Subp := Entity (Prefix (N)); 442 443 if not Expander_Active or else Get_PCS_Name = Name_No_DSA then 444 return; 445 end if; 446 447 if Ekind (RAS_Type) /= E_Record_Type then 448 RAS_Type := Equivalent_Type (RAS_Type); 449 end if; 450 451 Attribute_Subp := TSS (RAS_Type, TSS_RAS_Access); 452 pragma Assert (Present (Attribute_Subp)); 453 Remote_Subp_Decl := Unit_Declaration_Node (Remote_Subp); 454 455 if Nkind (Remote_Subp_Decl) = N_Subprogram_Body then 456 Remote_Subp := Corresponding_Spec (Remote_Subp_Decl); 457 Remote_Subp_Decl := Unit_Declaration_Node (Remote_Subp); 458 end if; 459 460 RS_Pkg_Specif := Parent (Remote_Subp_Decl); 461 RS_Pkg_E := Defining_Entity (RS_Pkg_Specif); 462 463 Async_E := 464 Boolean_Literals (Ekind (Remote_Subp) = E_Procedure 465 and then Is_Asynchronous (Remote_Subp)); 466 467 All_Calls_Remote_E := 468 Boolean_Literals (Has_All_Calls_Remote (RS_Pkg_E)); 469 470 Tick_Access_Conv_Call := 471 Make_Function_Call (Loc, 472 Name => New_Occurrence_Of (Attribute_Subp, Loc), 473 Parameter_Associations => 474 New_List ( 475 Make_String_Literal (Loc, 476 Strval => Full_Qualified_Name (RS_Pkg_E)), 477 Build_Subprogram_Id (Loc, Remote_Subp), 478 New_Occurrence_Of (Async_E, Loc), 479 New_Occurrence_Of (All_Calls_Remote_E, Loc))); 480 481 Rewrite (N, Tick_Access_Conv_Call); 482 Analyze_And_Resolve (N, RAS_Type); 483 end Process_Remote_AST_Attribute; 484 485 ------------------------------------ 486 -- Process_Remote_AST_Declaration -- 487 ------------------------------------ 488 489 procedure Process_Remote_AST_Declaration (N : Node_Id) is 490 Loc : constant Source_Ptr := Sloc (N); 491 User_Type : constant Node_Id := Defining_Identifier (N); 492 Scop : constant Entity_Id := Scope (User_Type); 493 Is_RCI : constant Boolean := Is_Remote_Call_Interface (Scop); 494 Is_RT : constant Boolean := Is_Remote_Types (Scop); 495 Type_Def : constant Node_Id := Type_Definition (N); 496 Parameter : Node_Id; 497 498 Is_Degenerate : Boolean; 499 -- True iff this RAS has an access formal parameter (see 500 -- Exp_Dist.Add_RAS_Dereference_TSS for details). 501 502 Subpkg : constant Entity_Id := Make_Temporary (Loc, 'S'); 503 Subpkg_Decl : Node_Id; 504 Subpkg_Body : Node_Id; 505 Vis_Decls : constant List_Id := New_List; 506 Priv_Decls : constant List_Id := New_List; 507 508 Obj_Type : constant Entity_Id := 509 Make_Defining_Identifier (Loc, 510 New_External_Name (Chars (User_Type), 'R')); 511 512 Full_Obj_Type : constant Entity_Id := 513 Make_Defining_Identifier (Loc, Chars (Obj_Type)); 514 515 RACW_Type : constant Entity_Id := 516 Make_Defining_Identifier (Loc, 517 New_External_Name (Chars (User_Type), 'P')); 518 519 Fat_Type : constant Entity_Id := 520 Make_Defining_Identifier (Loc, Chars (User_Type)); 521 522 Fat_Type_Decl : Node_Id; 523 524 begin 525 Is_Degenerate := False; 526 Parameter := First (Parameter_Specifications (Type_Def)); 527 while Present (Parameter) loop 528 if Nkind (Parameter_Type (Parameter)) = N_Access_Definition then 529 Error_Msg_N 530 ("formal parameter& has anonymous access type??", 531 Defining_Identifier (Parameter)); 532 Is_Degenerate := True; 533 exit; 534 end if; 535 536 Next (Parameter); 537 end loop; 538 539 if Is_Degenerate then 540 Error_Msg_NE 541 ("remote access-to-subprogram type& can only be null??", 542 Defining_Identifier (Parameter), User_Type); 543 544 -- The only legal value for a RAS with a formal parameter of an 545 -- anonymous access type is null, because it cannot be subtype- 546 -- conformant with any legal remote subprogram declaration. In this 547 -- case, we cannot generate a corresponding primitive operation. 548 549 end if; 550 551 if Get_PCS_Name = Name_No_DSA then 552 return; 553 end if; 554 555 -- The tagged private type, primitive operation and RACW type associated 556 -- with a RAS need to all be declared in a subpackage of the one that 557 -- contains the RAS declaration, because the primitive of the object 558 -- type, and the associated primitive of the stub type, need to be 559 -- dispatching operations of these types, and the profile of the RAS 560 -- might contain tagged types declared in the same scope. 561 562 Append_To (Vis_Decls, 563 Make_Private_Type_Declaration (Loc, 564 Defining_Identifier => Obj_Type, 565 Abstract_Present => True, 566 Tagged_Present => True, 567 Limited_Present => True)); 568 569 Append_To (Priv_Decls, 570 Make_Full_Type_Declaration (Loc, 571 Defining_Identifier => Full_Obj_Type, 572 Type_Definition => 573 Make_Record_Definition (Loc, 574 Abstract_Present => True, 575 Tagged_Present => True, 576 Limited_Present => True, 577 Null_Present => True, 578 Component_List => Empty))); 579 580 -- Trick semantic analysis into swapping the public and full view when 581 -- freezing the public view. 582 583 Set_Comes_From_Source (Full_Obj_Type, True); 584 585 if not Is_Degenerate then 586 Append_To (Vis_Decls, 587 Make_Abstract_Subprogram_Declaration (Loc, 588 Specification => Build_RAS_Primitive_Specification ( 589 Subp_Spec => Type_Def, 590 Remote_Object_Type => Obj_Type))); 591 end if; 592 593 Append_To (Vis_Decls, 594 Make_Full_Type_Declaration (Loc, 595 Defining_Identifier => RACW_Type, 596 Type_Definition => 597 Make_Access_To_Object_Definition (Loc, 598 All_Present => True, 599 Subtype_Indication => 600 Make_Attribute_Reference (Loc, 601 Prefix => New_Occurrence_Of (Obj_Type, Loc), 602 Attribute_Name => Name_Class)))); 603 604 Set_Is_Remote_Call_Interface (RACW_Type, Is_RCI); 605 Set_Is_Remote_Types (RACW_Type, Is_RT); 606 607 Subpkg_Decl := 608 Make_Package_Declaration (Loc, 609 Make_Package_Specification (Loc, 610 Defining_Unit_Name => Subpkg, 611 Visible_Declarations => Vis_Decls, 612 Private_Declarations => Priv_Decls, 613 End_Label => New_Occurrence_Of (Subpkg, Loc))); 614 615 Set_Is_Remote_Call_Interface (Subpkg, Is_RCI); 616 Set_Is_Remote_Types (Subpkg, Is_RT); 617 Insert_After_And_Analyze (N, Subpkg_Decl); 618 619 -- Generate package body to receive RACW calling stubs 620 621 -- Note: Analyze_Declarations has an absolute requirement that the 622 -- declaration list be non-empty, so provide dummy null statement here. 623 624 Subpkg_Body := 625 Make_Package_Body (Loc, 626 Defining_Unit_Name => Make_Defining_Identifier (Loc, Chars (Subpkg)), 627 Declarations => New_List (Make_Null_Statement (Loc))); 628 Insert_After_And_Analyze (Subpkg_Decl, Subpkg_Body); 629 630 -- Many parts of the analyzer and expander expect 631 -- that the fat pointer type used to implement remote 632 -- access to subprogram types be a record. 633 -- Note: The structure of this type must be kept consistent 634 -- with the code generated by Remote_AST_Null_Value for the 635 -- corresponding 'null' expression. 636 637 Fat_Type_Decl := Make_Full_Type_Declaration (Loc, 638 Defining_Identifier => Fat_Type, 639 Type_Definition => 640 Make_Record_Definition (Loc, 641 Component_List => 642 Make_Component_List (Loc, 643 Component_Items => New_List ( 644 Make_Component_Declaration (Loc, 645 Defining_Identifier => 646 Make_Defining_Identifier (Loc, Name_Ras), 647 Component_Definition => 648 Make_Component_Definition (Loc, 649 Aliased_Present => False, 650 Subtype_Indication => 651 New_Occurrence_Of (RACW_Type, Loc))))))); 652 653 Set_Equivalent_Type (User_Type, Fat_Type); 654 655 -- Set Fat_Type's Etype early so that we can use its 656 -- Corresponding_Remote_Type attribute, whose presence indicates that 657 -- this is the record type used to implement a RAS. 658 659 Set_Ekind (Fat_Type, E_Record_Type); 660 Set_Corresponding_Remote_Type (Fat_Type, User_Type); 661 662 Insert_After_And_Analyze (Subpkg_Body, Fat_Type_Decl); 663 664 -- The reason we suppress the initialization procedure is that we know 665 -- that no initialization is required (even if Initialize_Scalars mode 666 -- is active), and there are order of elaboration problems if we do try 667 -- to generate an init proc for this created record type. 668 669 Set_Suppress_Initialization (Fat_Type); 670 671 if Expander_Active then 672 Add_RAST_Features (Parent (User_Type)); 673 end if; 674 end Process_Remote_AST_Declaration; 675 676 ----------------------- 677 -- RAS_E_Dereference -- 678 ----------------------- 679 680 procedure RAS_E_Dereference (Pref : Node_Id) is 681 Loc : constant Source_Ptr := Sloc (Pref); 682 Call_Node : Node_Id; 683 New_Type : constant Entity_Id := Etype (Pref); 684 Explicit_Deref : constant Node_Id := Parent (Pref); 685 Deref_Subp_Call : constant Node_Id := Parent (Explicit_Deref); 686 Deref_Proc : Entity_Id; 687 Params : List_Id; 688 689 begin 690 if Nkind (Deref_Subp_Call) = N_Procedure_Call_Statement then 691 Params := Parameter_Associations (Deref_Subp_Call); 692 693 if Present (Params) then 694 Prepend (Pref, Params); 695 else 696 Params := New_List (Pref); 697 end if; 698 699 elsif Nkind (Deref_Subp_Call) = N_Indexed_Component then 700 Params := Expressions (Deref_Subp_Call); 701 702 if Present (Params) then 703 Prepend (Pref, Params); 704 else 705 Params := New_List (Pref); 706 end if; 707 708 else 709 -- Context is not a call 710 711 return; 712 end if; 713 714 if not Expander_Active or else Get_PCS_Name = Name_No_DSA then 715 return; 716 end if; 717 718 Deref_Proc := TSS (New_Type, TSS_RAS_Dereference); 719 pragma Assert (Present (Deref_Proc)); 720 721 if Ekind (Deref_Proc) = E_Function then 722 Call_Node := 723 Make_Function_Call (Loc, 724 Name => New_Occurrence_Of (Deref_Proc, Loc), 725 Parameter_Associations => Params); 726 else 727 Call_Node := 728 Make_Procedure_Call_Statement (Loc, 729 Name => New_Occurrence_Of (Deref_Proc, Loc), 730 Parameter_Associations => Params); 731 end if; 732 733 Rewrite (Deref_Subp_Call, Call_Node); 734 Analyze (Deref_Subp_Call); 735 end RAS_E_Dereference; 736 737 ------------------------------ 738 -- Remote_AST_E_Dereference -- 739 ------------------------------ 740 741 function Remote_AST_E_Dereference (P : Node_Id) return Boolean is 742 ET : constant Entity_Id := Etype (P); 743 744 begin 745 -- Perform the changes only on original dereferences, and only if 746 -- we are generating code. 747 748 if Comes_From_Source (P) 749 and then Is_Record_Type (ET) 750 and then (Is_Remote_Call_Interface (ET) 751 or else Is_Remote_Types (ET)) 752 and then Present (Corresponding_Remote_Type (ET)) 753 and then Nkind_In (Parent (Parent (P)), N_Procedure_Call_Statement, 754 N_Indexed_Component) 755 and then Expander_Active 756 then 757 RAS_E_Dereference (P); 758 return True; 759 else 760 return False; 761 end if; 762 end Remote_AST_E_Dereference; 763 764 ------------------------------ 765 -- Remote_AST_I_Dereference -- 766 ------------------------------ 767 768 function Remote_AST_I_Dereference (P : Node_Id) return Boolean is 769 ET : constant Entity_Id := Etype (P); 770 Deref : Node_Id; 771 772 begin 773 if Comes_From_Source (P) 774 and then (Is_Remote_Call_Interface (ET) 775 or else Is_Remote_Types (ET)) 776 and then Present (Corresponding_Remote_Type (ET)) 777 and then Ekind (Entity (P)) /= E_Function 778 then 779 Deref := 780 Make_Explicit_Dereference (Sloc (P), 781 Prefix => Relocate_Node (P)); 782 Rewrite (P, Deref); 783 Set_Etype (P, ET); 784 RAS_E_Dereference (Prefix (P)); 785 return True; 786 end if; 787 788 return False; 789 end Remote_AST_I_Dereference; 790 791 --------------------------- 792 -- Remote_AST_Null_Value -- 793 --------------------------- 794 795 function Remote_AST_Null_Value 796 (N : Node_Id; 797 Typ : Entity_Id) return Boolean 798 is 799 Loc : constant Source_Ptr := Sloc (N); 800 Target_Type : Entity_Id; 801 802 begin 803 if not Expander_Active or else Get_PCS_Name = Name_No_DSA then 804 return False; 805 806 elsif Ekind (Typ) = E_Access_Subprogram_Type 807 and then (Is_Remote_Call_Interface (Typ) 808 or else Is_Remote_Types (Typ)) 809 and then Comes_From_Source (N) 810 and then Expander_Active 811 then 812 -- Any null that comes from source and is of the RAS type must 813 -- be expanded, except if expansion is not active (nothing 814 -- gets expanded into the equivalent record type). 815 816 Target_Type := Equivalent_Type (Typ); 817 818 elsif Ekind (Typ) = E_Record_Type 819 and then Present (Corresponding_Remote_Type (Typ)) 820 then 821 -- This is a record type representing a RAS type, this must be 822 -- expanded. 823 824 Target_Type := Typ; 825 826 else 827 -- We do not have to handle this case 828 829 return False; 830 end if; 831 832 Rewrite (N, 833 Make_Aggregate (Loc, 834 Component_Associations => New_List ( 835 Make_Component_Association (Loc, 836 Choices => New_List (Make_Identifier (Loc, Name_Ras)), 837 Expression => Make_Null (Loc))))); 838 Analyze_And_Resolve (N, Target_Type); 839 return True; 840 end Remote_AST_Null_Value; 841 842end Sem_Dist; 843