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