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-2005, 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 2,  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 COPYING.  If not, write --
  19 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, USA.                                                      --
  21 --                                                                          --
  22 -- GNAT was originally developed  by the GNAT team at  New York University. --
  23 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  24 --                                                                          --
  25 ------------------------------------------------------------------------------
  26
  27 with Atree;    use Atree;
  28 with Casing;   use Casing;
  29 with Einfo;    use Einfo;
  30 with Errout;   use Errout;
  31 with Exp_Dist; use Exp_Dist;
  32 with Exp_Tss;  use Exp_Tss;
  33 with Nlists;   use Nlists;
  34 with Nmake;    use Nmake;
  35 with Namet;    use Namet;
  36 with Opt;      use Opt;
  37 with Rtsfind;  use Rtsfind;
  38 with Sem;      use Sem;
  39 with Sem_Res;  use Sem_Res;
  40 with Sem_Util; use Sem_Util;
  41 with Sinfo;    use Sinfo;
  42 with Snames;   use Snames;
  43 with Stand;    use Stand;
  44 with Stringt;  use Stringt;
  45 with Tbuild;   use Tbuild;
  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_Call);
 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
 147       --  operation as a primitive (dispatching) operation of
 148       --  tagged type Obj_Type.
 149
 150       Set_Comes_From_Source (
 151         Defining_Unit_Name (Primitive_Spec), True);
 152
 153       return Primitive_Spec;
 154    end Build_RAS_Primitive_Specification;
 155
 156    -------------------------
 157    -- Full_Qualified_Name --
 158    -------------------------
 159
 160    function Full_Qualified_Name (E : Entity_Id) return String_Id is
 161       Ent         : Entity_Id := E;
 162       Parent_Name : String_Id := No_String;
 163
 164    begin
 165       --  Deals properly with child units
 166
 167       if Nkind (Ent) = N_Defining_Program_Unit_Name then
 168          Ent := Defining_Identifier (Ent);
 169       end if;
 170
 171       --  Compute recursively the qualification. Only "Standard" has no scope.
 172
 173       if Present (Scope (Scope (Ent))) then
 174          Parent_Name := Full_Qualified_Name (Scope (Ent));
 175       end if;
 176
 177       --  Every entity should have a name except some expanded blocks
 178       --  don't bother about those.
 179
 180       if Chars (Ent) = No_Name then
 181          return Parent_Name;
 182       end if;
 183
 184       --  Add a period between Name and qualification
 185
 186       if Parent_Name /= No_String then
 187          Start_String (Parent_Name);
 188          Store_String_Char (Get_Char_Code ('.'));
 189
 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       PCS_Name : constant PCS_Names :=
 208                    Chars (Entity (Expression
 209                                     (Parent (RTE (RE_DSA_Implementation)))));
 210    begin
 211       return PCS_Name;
 212    end Get_PCS_Name;
 213
 214    ------------------------
 215    -- Is_All_Remote_Call --
 216    ------------------------
 217
 218    function Is_All_Remote_Call (N : Node_Id) return Boolean is
 219       Par : Node_Id;
 220
 221    begin
 222       if (Nkind (N) = N_Function_Call
 223               or else Nkind (N) = N_Procedure_Call_Statement)
 224         and then Nkind (Name (N)) in N_Has_Entity
 225         and then Is_Remote_Call_Interface (Entity (Name (N)))
 226         and then Has_All_Calls_Remote (Scope (Entity (Name (N))))
 227         and then Comes_From_Source (N)
 228       then
 229          Par := Parent (Entity (Name (N)));
 230
 231          while Present (Par)
 232            and then (Nkind (Par) /= N_Package_Specification
 233                        or else Is_Wrapper_Package (Defining_Entity (Par)))
 234          loop
 235             Par := Parent (Par);
 236          end loop;
 237
 238          if Present (Par) then
 239             return
 240               not Scope_Within_Or_Same (Current_Scope, Defining_Entity (Par));
 241          else
 242             return False;
 243          end if;
 244       else
 245          return False;
 246       end if;
 247    end Is_All_Remote_Call;
 248
 249    ------------------------------------
 250    -- Package_Specification_Of_Scope --
 251    ------------------------------------
 252
 253    function Package_Specification_Of_Scope (E : Entity_Id) return Node_Id is
 254       N : Node_Id := Parent (E);
 255    begin
 256       while Nkind (N) /= N_Package_Specification loop
 257          N := Parent (N);
 258       end loop;
 259
 260       return N;
 261    end Package_Specification_Of_Scope;
 262
 263    --------------------------
 264    -- Process_Partition_ID --
 265    --------------------------
 266
 267    procedure Process_Partition_Id (N : Node_Id) is
 268       Loc            : constant Source_Ptr := Sloc (N);
 269       Ety            : Entity_Id;
 270       Get_Pt_Id      : Node_Id;
 271       Get_Pt_Id_Call : Node_Id;
 272       Prefix_String  : String_Id;
 273       Typ            : constant Entity_Id := Etype (N);
 274
 275    begin
 276       Ety := Entity (Prefix (N));
 277
 278       --  In case prefix is not a library unit entity, get the entity
 279       --  of library unit.
 280
 281       while (Present (Scope (Ety))
 282         and then Scope (Ety) /= Standard_Standard)
 283         and not Is_Child_Unit (Ety)
 284       loop
 285          Ety := Scope (Ety);
 286       end loop;
 287
 288       --  Retrieve the proper function to call.
 289
 290       if Is_Remote_Call_Interface (Ety) then
 291          Get_Pt_Id := New_Occurrence_Of
 292            (RTE (RE_Get_Active_Partition_Id), Loc);
 293
 294       elsif Is_Shared_Passive (Ety) then
 295          Get_Pt_Id := New_Occurrence_Of
 296            (RTE (RE_Get_Passive_Partition_Id), Loc);
 297
 298       else
 299          Get_Pt_Id := New_Occurrence_Of
 300            (RTE (RE_Get_Local_Partition_Id), Loc);
 301       end if;
 302
 303       --  Get and store the String_Id corresponding to the name of the
 304       --  library unit whose Partition_Id is needed.
 305
 306       Get_Library_Unit_Name_String (Unit_Declaration_Node (Ety));
 307       Prefix_String := String_From_Name_Buffer;
 308
 309       --  Build the function call which will replace the attribute
 310
 311       if Is_Remote_Call_Interface (Ety)
 312         or else Is_Shared_Passive (Ety)
 313       then
 314          Get_Pt_Id_Call :=
 315            Make_Function_Call (Loc,
 316              Name => Get_Pt_Id,
 317              Parameter_Associations =>
 318                New_List (Make_String_Literal (Loc, Prefix_String)));
 319
 320       else
 321          Get_Pt_Id_Call := Make_Function_Call (Loc, Get_Pt_Id);
 322
 323       end if;
 324
 325       --  Replace the attribute node by a conversion of the function call
 326       --  to the target type.
 327
 328       Rewrite (N, Convert_To (Typ, Get_Pt_Id_Call));
 329       Analyze_And_Resolve (N, Typ);
 330    end Process_Partition_Id;
 331
 332    ----------------------------------
 333    -- Process_Remote_AST_Attribute --
 334    ----------------------------------
 335
 336    procedure Process_Remote_AST_Attribute
 337      (N        : Node_Id;
 338       New_Type : Entity_Id)
 339    is
 340       Loc                   : constant Source_Ptr := Sloc (N);
 341       Remote_Subp           : Entity_Id;
 342       Tick_Access_Conv_Call : Node_Id;
 343       Remote_Subp_Decl      : Node_Id;
 344       RS_Pkg_Specif         : Node_Id;
 345       RS_Pkg_E              : Entity_Id;
 346       RAS_Type              : Entity_Id := New_Type;
 347       Async_E               : Entity_Id;
 348       All_Calls_Remote_E    : Entity_Id;
 349       Attribute_Subp        : Entity_Id;
 350
 351    begin
 352       --  Check if we have to expand the access attribute
 353
 354       Remote_Subp := Entity (Prefix (N));
 355
 356       if not Expander_Active or else Get_PCS_Name = Name_No_DSA then
 357          return;
 358       end if;
 359
 360       if Ekind (RAS_Type) /= E_Record_Type then
 361          RAS_Type := Equivalent_Type (RAS_Type);
 362       end if;
 363
 364       Attribute_Subp := TSS (RAS_Type, TSS_RAS_Access);
 365       pragma Assert (Present (Attribute_Subp));
 366       Remote_Subp_Decl := Unit_Declaration_Node (Remote_Subp);
 367
 368       if Nkind (Remote_Subp_Decl) = N_Subprogram_Body then
 369          Remote_Subp := Corresponding_Spec (Remote_Subp_Decl);
 370          Remote_Subp_Decl := Unit_Declaration_Node (Remote_Subp);
 371       end if;
 372
 373       RS_Pkg_Specif := Parent (Remote_Subp_Decl);
 374       RS_Pkg_E := Defining_Entity (RS_Pkg_Specif);
 375
 376       Async_E :=
 377         Boolean_Literals (Ekind (Remote_Subp) = E_Procedure
 378                             and then Is_Asynchronous (Remote_Subp));
 379
 380       All_Calls_Remote_E :=
 381         Boolean_Literals (Has_All_Calls_Remote (RS_Pkg_E));
 382
 383       Tick_Access_Conv_Call :=
 384         Make_Function_Call (Loc,
 385           Name => New_Occurrence_Of (Attribute_Subp, Loc),
 386           Parameter_Associations =>
 387             New_List (
 388               Make_String_Literal (Loc, Full_Qualified_Name (RS_Pkg_E)),
 389               Build_Subprogram_Id (Loc, Remote_Subp),
 390               New_Occurrence_Of (Async_E, Loc),
 391               New_Occurrence_Of (All_Calls_Remote_E, Loc)));
 392
 393       Rewrite (N, Tick_Access_Conv_Call);
 394       Analyze_And_Resolve (N, RAS_Type);
 395    end Process_Remote_AST_Attribute;
 396
 397    ------------------------------------
 398    -- Process_Remote_AST_Declaration --
 399    ------------------------------------
 400
 401    procedure Process_Remote_AST_Declaration (N : Node_Id) is
 402       Loc            : constant Source_Ptr := Sloc (N);
 403       User_Type      : constant Node_Id := Defining_Identifier (N);
 404       Scop           : constant Entity_Id := Scope (User_Type);
 405       Is_RCI         : constant Boolean :=
 406         Is_Remote_Call_Interface (Scop);
 407       Is_RT          : constant Boolean :=
 408         Is_Remote_Types (Scop);
 409       Type_Def       : constant Node_Id := Type_Definition (N);
 410
 411       Parameter      : Node_Id;
 412       Is_Degenerate  : Boolean;
 413       --  True iff this RAS has an access formal parameter (see
 414       --  Exp_Dist.Add_RAS_Dereference_TSS for details).
 415
 416       Subpkg         : constant Entity_Id :=
 417                          Make_Defining_Identifier
 418                            (Loc, New_Internal_Name ('S'));
 419       Subpkg_Decl    : Node_Id;
 420       Vis_Decls      : constant List_Id := New_List;
 421       Priv_Decls     : constant List_Id := New_List;
 422
 423       Obj_Type       : constant Entity_Id :=
 424                          Make_Defining_Identifier
 425                            (Loc, New_External_Name (
 426                                    Chars (User_Type), 'R'));
 427
 428
 429       Full_Obj_Type  : constant Entity_Id :=
 430                          Make_Defining_Identifier
 431                            (Loc, Chars (Obj_Type));
 432
 433       RACW_Type      : constant Entity_Id :=
 434                          Make_Defining_Identifier
 435                            (Loc, New_External_Name (
 436                                    Chars (User_Type), 'P'));
 437
 438       Fat_Type       : constant Entity_Id :=
 439                         Make_Defining_Identifier
 440                           (Loc, Chars (User_Type));
 441       Fat_Type_Decl  : Node_Id;
 442
 443    begin
 444       Is_Degenerate := False;
 445       Parameter := First (Parameter_Specifications (Type_Def));
 446       while Present (Parameter) loop
 447          if Nkind (Parameter_Type (Parameter)) = N_Access_Definition then
 448             Error_Msg_N ("formal parameter& has anonymous access type?",
 449               Defining_Identifier (Parameter));
 450             Is_Degenerate := True;
 451             exit;
 452          end if;
 453
 454          Next (Parameter);
 455       end loop;
 456
 457       if Is_Degenerate then
 458          Error_Msg_NE (
 459            "remote access-to-subprogram type& can only be null?",
 460            Defining_Identifier (Parameter), User_Type);
 461          --  The only legal value for a RAS with a formal parameter of an
 462          --  anonymous access type is null, because it cannot be
 463          --  subtype-Conformant with any legal remote subprogram declaration.
 464          --  In this case, we cannot generate a corresponding primitive
 465          --  operation.
 466       end if;
 467
 468       if Get_PCS_Name = Name_No_DSA then
 469          return;
 470       end if;
 471
 472       --  The tagged private type, primitive operation and RACW
 473       --  type associated with a RAS need to all be declared in
 474       --  a subpackage of the one that contains the RAS declaration,
 475       --  because the primitive of the object type, and the associated
 476       --  primitive of the stub type, need to be dispatching operations
 477       --  of these types, and the profile of the RAS might contain
 478       --  tagged types declared in the same scope.
 479
 480       Append_To (Vis_Decls,
 481         Make_Private_Type_Declaration (Loc,
 482           Defining_Identifier => Obj_Type,
 483           Abstract_Present => True,
 484           Tagged_Present   => True,
 485           Limited_Present  => True));
 486
 487       Append_To (Priv_Decls,
 488         Make_Full_Type_Declaration (Loc,
 489           Defining_Identifier =>
 490             Full_Obj_Type,
 491           Type_Definition     =>
 492             Make_Record_Definition (Loc,
 493               Abstract_Present => True,
 494               Tagged_Present   => True,
 495               Limited_Present  => True,
 496               Null_Present     => True,
 497               Component_List   => Empty)));
 498
 499       if not Is_Degenerate then
 500          Append_To (Vis_Decls,
 501            Make_Abstract_Subprogram_Declaration (Loc,
 502              Specification => Build_RAS_Primitive_Specification (
 503                Subp_Spec          => Type_Def,
 504                Remote_Object_Type => Obj_Type)));
 505       end if;
 506
 507       Append_To (Vis_Decls,
 508         Make_Full_Type_Declaration (Loc,
 509           Defining_Identifier => RACW_Type,
 510           Type_Definition     =>
 511             Make_Access_To_Object_Definition (Loc,
 512               All_Present => True,
 513               Subtype_Indication =>
 514                 Make_Attribute_Reference (Loc,
 515                   Prefix =>
 516                     New_Occurrence_Of (Obj_Type, Loc),
 517                   Attribute_Name =>
 518                     Name_Class))));
 519       Set_Is_Remote_Call_Interface (RACW_Type, Is_RCI);
 520       Set_Is_Remote_Types (RACW_Type, Is_RT);
 521
 522       Subpkg_Decl :=
 523         Make_Package_Declaration (Loc,
 524           Make_Package_Specification (Loc,
 525             Defining_Unit_Name =>
 526               Subpkg,
 527             Visible_Declarations =>
 528               Vis_Decls,
 529             Private_Declarations =>
 530               Priv_Decls,
 531             End_Label =>
 532               New_Occurrence_Of (Subpkg, Loc)));
 533       Set_Is_Remote_Call_Interface (Subpkg, Is_RCI);
 534       Set_Is_Remote_Types (Subpkg, Is_RT);
 535       Insert_After_And_Analyze (N, Subpkg_Decl);
 536
 537       --  Many parts of the analyzer and expander expect
 538       --  that the fat pointer type used to implement remote
 539       --  access to subprogram types be a record.
 540       --  Note: The structure of this type must be kept consistent
 541       --  with the code generated by Remote_AST_Null_Value for the
 542       --  corresponding 'null' expression.
 543
 544       Fat_Type_Decl := Make_Full_Type_Declaration (Loc,
 545         Defining_Identifier => Fat_Type,
 546         Type_Definition     =>
 547           Make_Record_Definition (Loc,
 548             Component_List =>
 549               Make_Component_List (Loc,
 550                 Component_Items => New_List (
 551                   Make_Component_Declaration (Loc,
 552                     Defining_Identifier =>
 553                       Make_Defining_Identifier (Loc, Name_Ras),
 554                     Component_Definition =>
 555                       Make_Component_Definition (Loc,
 556                         Aliased_Present     =>
 557                           False,
 558                         Subtype_Indication  =>
 559                           New_Occurrence_Of (RACW_Type, Loc)))))));
 560       Set_Equivalent_Type (User_Type, Fat_Type);
 561       Set_Corresponding_Remote_Type (Fat_Type, User_Type);
 562       Insert_After_And_Analyze (Subpkg_Decl, Fat_Type_Decl);
 563
 564       --  The reason we suppress the initialization procedure is that we know
 565       --  that no initialization is required (even if Initialize_Scalars mode
 566       --  is active), and there are order of elaboration problems if we do try
 567       --  to generate an init proc for this created record type.
 568
 569       Set_Suppress_Init_Proc (Fat_Type);
 570
 571       if Expander_Active then
 572          Add_RAST_Features (Parent (User_Type));
 573       end if;
 574    end Process_Remote_AST_Declaration;
 575
 576    -----------------------
 577    -- RAS_E_Dereference --
 578    -----------------------
 579
 580    procedure RAS_E_Dereference (Pref : Node_Id) is
 581       Loc             : constant Source_Ptr := Sloc (Pref);
 582       Call_Node       : Node_Id;
 583       New_Type        : constant Entity_Id := Etype (Pref);
 584       Explicit_Deref  : constant Node_Id   := Parent (Pref);
 585       Deref_Subp_Call : constant Node_Id   := Parent (Explicit_Deref);
 586       Deref_Proc      : Entity_Id;
 587       Params          : List_Id;
 588
 589    begin
 590       if Nkind (Deref_Subp_Call) = N_Procedure_Call_Statement then
 591          Params := Parameter_Associations (Deref_Subp_Call);
 592
 593          if Present (Params) then
 594             Prepend (Pref, Params);
 595          else
 596             Params := New_List (Pref);
 597          end if;
 598
 599       elsif Nkind (Deref_Subp_Call) = N_Indexed_Component then
 600
 601          Params := Expressions (Deref_Subp_Call);
 602
 603          if Present (Params) then
 604             Prepend (Pref, Params);
 605          else
 606             Params := New_List (Pref);
 607          end if;
 608
 609       else
 610          --  Context is not a call.
 611
 612          return;
 613       end if;
 614
 615       if not Expander_Active or else Get_PCS_Name = Name_No_DSA then
 616          return;
 617       end if;
 618
 619       Deref_Proc := TSS (New_Type, TSS_RAS_Dereference);
 620       pragma Assert (Present (Deref_Proc));
 621
 622       if Ekind (Deref_Proc) = E_Function then
 623          Call_Node :=
 624            Make_Function_Call (Loc,
 625               Name => New_Occurrence_Of (Deref_Proc, Loc),
 626               Parameter_Associations => Params);
 627
 628       else
 629          Call_Node :=
 630            Make_Procedure_Call_Statement (Loc,
 631               Name => New_Occurrence_Of (Deref_Proc, Loc),
 632               Parameter_Associations => Params);
 633       end if;
 634
 635       Rewrite (Deref_Subp_Call, Call_Node);
 636       Analyze (Deref_Subp_Call);
 637    end RAS_E_Dereference;
 638
 639    ------------------------------
 640    -- Remote_AST_E_Dereference --
 641    ------------------------------
 642
 643    function Remote_AST_E_Dereference (P : Node_Id) return Boolean is
 644       ET : constant Entity_Id  := Etype (P);
 645
 646    begin
 647       --  Perform the changes only on original dereferences, and only if
 648       --  we are generating code.
 649
 650       if Comes_From_Source (P)
 651         and then Is_Record_Type (ET)
 652         and then (Is_Remote_Call_Interface (ET)
 653                    or else Is_Remote_Types (ET))
 654         and then Present (Corresponding_Remote_Type (ET))
 655         and then (Nkind (Parent (Parent (P))) = N_Procedure_Call_Statement
 656                    or else Nkind (Parent (Parent (P))) = N_Indexed_Component)
 657         and then Expander_Active
 658       then
 659          RAS_E_Dereference (P);
 660          return True;
 661       else
 662          return False;
 663       end if;
 664    end Remote_AST_E_Dereference;
 665
 666    ------------------------------
 667    -- Remote_AST_I_Dereference --
 668    ------------------------------
 669
 670    function Remote_AST_I_Dereference (P : Node_Id) return Boolean is
 671       ET     : constant Entity_Id  := Etype (P);
 672       Deref  : Node_Id;
 673
 674    begin
 675       if Comes_From_Source (P)
 676         and then (Is_Remote_Call_Interface (ET)
 677                    or else Is_Remote_Types (ET))
 678         and then Present (Corresponding_Remote_Type (ET))
 679         and then Ekind (Entity (P)) /= E_Function
 680       then
 681          Deref :=
 682            Make_Explicit_Dereference (Sloc (P),
 683              Prefix => Relocate_Node (P));
 684          Rewrite (P, Deref);
 685          Set_Etype (P, ET);
 686          RAS_E_Dereference (Prefix (P));
 687          return True;
 688       end if;
 689
 690       return False;
 691    end Remote_AST_I_Dereference;
 692
 693    ---------------------------
 694    -- Remote_AST_Null_Value --
 695    ---------------------------
 696
 697    function Remote_AST_Null_Value
 698      (N   : Node_Id;
 699       Typ : Entity_Id) return Boolean
 700    is
 701       Loc         : constant Source_Ptr := Sloc (N);
 702       Target_Type : Entity_Id;
 703
 704    begin
 705       if not Expander_Active or else Get_PCS_Name = Name_No_DSA then
 706          return False;
 707
 708       elsif Ekind (Typ) = E_Access_Subprogram_Type
 709         and then (Is_Remote_Call_Interface (Typ)
 710                     or else Is_Remote_Types (Typ))
 711         and then Comes_From_Source (N)
 712         and then Expander_Active
 713       then
 714          --  Any null that comes from source and is of the RAS type must
 715          --  be expanded, except if expansion is not active (nothing
 716          --  gets expanded into the equivalent record type).
 717
 718          Target_Type := Equivalent_Type (Typ);
 719
 720       elsif Ekind (Typ) = E_Record_Type
 721         and then Present (Corresponding_Remote_Type (Typ))
 722       then
 723          --  This is a record type representing a RAS type, this must be
 724          --  expanded.
 725
 726          Target_Type := Typ;
 727
 728       else
 729          --  We do not have to handle this case
 730
 731          return False;
 732
 733       end if;
 734
 735       Rewrite (N,
 736         Make_Aggregate (Loc,
 737           Component_Associations => New_List (
 738             Make_Component_Association (Loc,
 739               Choices => New_List (
 740                 Make_Identifier (Loc, Name_Ras)),
 741               Expression =>
 742                 Make_Null (Loc)))));
 743       Analyze_And_Resolve (N, Target_Type);
 744       return True;
 745    end Remote_AST_Null_Value;
 746
 747 end Sem_Dist;