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