gcc/ada/sem_dist.adb

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