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