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-2008, 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_Disp; use Sem_Disp;
  39 with Sem_Eval; use Sem_Eval;
  40 with Sem_Res;  use Sem_Res;
  41 with Sem_Util; use Sem_Util;
  42 with Sinfo;    use Sinfo;
  43 with Stand;    use Stand;
  44 with Stringt;  use Stringt;
  45 with Tbuild;   use Tbuild;
  46 with Uintp;    use Uintp;
  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
  68       Exp : Node_Id := U;
  69       --  Unit that will be expanded
  70
  71    begin
  72       pragma Assert (Distribution_Stub_Mode /= No_Stubs);
  73
  74       if Nkind (U) = N_Package_Declaration then
  75          Spec := Defining_Entity (Specification (U));
  76
  77       elsif Nkind (U) = N_Package_Body then
  78          Spec := Corresponding_Spec (U);
  79
  80       else pragma Assert (Nkind (U) = N_Package_Instantiation);
  81          Exp  := Instance_Spec (U);
  82          Spec := Defining_Entity (Specification (Exp));
  83       end if;
  84
  85       pragma Assert (Is_Shared_Passive (Spec)
  86         or else Is_Remote_Call_Interface (Spec));
  87
  88       if Distribution_Stub_Mode = Generate_Caller_Stub_Body then
  89          if Is_Shared_Passive (Spec) then
  90             null;
  91          elsif Nkind (U) = N_Package_Body then
  92             Error_Msg_N
  93               ("Specification file expected from command line", U);
  94          else
  95             Expand_Calling_Stubs_Bodies (Exp);
  96          end if;
  97
  98       else
  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_uCall);
 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 operation as a
 148       --  primitive (dispatching) operation of 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. Do not
 178       --  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       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_In (N, N_Function_Call, N_Procedure_Call_Statement)
 245         and then Nkind (Name (N)) in N_Has_Entity
 246         and then Is_Remote_Call_Interface (Entity (Name (N)))
 247         and then Has_All_Calls_Remote (Scope (Entity (Name (N))))
 248         and then Comes_From_Source (N)
 249       then
 250          Par := Parent (Entity (Name (N)));
 251          while Present (Par)
 252            and then (Nkind (Par) /= N_Package_Specification
 253                        or else Is_Wrapper_Package (Defining_Entity (Par)))
 254          loop
 255             Par := Parent (Par);
 256          end loop;
 257
 258          if Present (Par) then
 259             return
 260               not Scope_Within_Or_Same (Current_Scope, Defining_Entity (Par));
 261          else
 262             return False;
 263          end if;
 264       else
 265          return False;
 266       end if;
 267    end Is_All_Remote_Call;
 268
 269    ---------------------------------
 270    -- Is_RACW_Stub_Type_Operation --
 271    ---------------------------------
 272
 273    function Is_RACW_Stub_Type_Operation (Op : Entity_Id) return Boolean is
 274       Dispatching_Type : Entity_Id;
 275
 276    begin
 277       case Ekind (Op) is
 278          when E_Function | E_Procedure =>
 279             Dispatching_Type := Find_Dispatching_Type (Op);
 280             return Present (Dispatching_Type)
 281                      and then Is_RACW_Stub_Type (Dispatching_Type)
 282                      and then not Is_Internal (Op);
 283
 284          when others =>
 285             return False;
 286       end case;
 287    end Is_RACW_Stub_Type_Operation;
 288
 289    ------------------------------------
 290    -- Package_Specification_Of_Scope --
 291    ------------------------------------
 292
 293    function Package_Specification_Of_Scope (E : Entity_Id) return Node_Id is
 294       N : Node_Id;
 295
 296    begin
 297       N := Parent (E);
 298       while Nkind (N) /= N_Package_Specification loop
 299          N := Parent (N);
 300       end loop;
 301
 302       return N;
 303    end Package_Specification_Of_Scope;
 304
 305    --------------------------
 306    -- Process_Partition_ID --
 307    --------------------------
 308
 309    procedure Process_Partition_Id (N : Node_Id) is
 310       Loc            : constant Source_Ptr := Sloc (N);
 311       Ety            : Entity_Id;
 312       Get_Pt_Id      : Node_Id;
 313       Get_Pt_Id_Call : Node_Id;
 314       Prefix_String  : String_Id;
 315       Typ            : constant Entity_Id := Etype (N);
 316
 317    begin
 318       --  In case prefix is not a library unit entity, get the entity
 319       --  of library unit.
 320
 321       Ety := Entity (Prefix (N));
 322       while (Present (Scope (Ety))
 323         and then Scope (Ety) /= Standard_Standard)
 324         and not Is_Child_Unit (Ety)
 325       loop
 326          Ety := Scope (Ety);
 327       end loop;
 328
 329       --  Retrieve the proper function to call
 330
 331       if Is_Remote_Call_Interface (Ety) then
 332          Get_Pt_Id := New_Occurrence_Of
 333            (RTE (RE_Get_Active_Partition_Id), Loc);
 334
 335       elsif Is_Shared_Passive (Ety) then
 336          Get_Pt_Id := New_Occurrence_Of
 337            (RTE (RE_Get_Passive_Partition_Id), Loc);
 338
 339       else
 340          Get_Pt_Id := New_Occurrence_Of
 341            (RTE (RE_Get_Local_Partition_Id), Loc);
 342       end if;
 343
 344       --  Get and store the String_Id corresponding to the name of the
 345       --  library unit whose Partition_Id is needed.
 346
 347       Get_Library_Unit_Name_String (Unit_Declaration_Node (Ety));
 348       Prefix_String := String_From_Name_Buffer;
 349
 350       --  Build the function call which will replace the attribute
 351
 352       if Is_Remote_Call_Interface (Ety)
 353         or else Is_Shared_Passive (Ety)
 354       then
 355          Get_Pt_Id_Call :=
 356            Make_Function_Call (Loc,
 357              Name => Get_Pt_Id,
 358              Parameter_Associations =>
 359                New_List (Make_String_Literal (Loc, Prefix_String)));
 360
 361       else
 362          Get_Pt_Id_Call := Make_Function_Call (Loc, Get_Pt_Id);
 363       end if;
 364
 365       --  Replace the attribute node by a conversion of the function call
 366       --  to the target type.
 367
 368       Rewrite (N, Convert_To (Typ, Get_Pt_Id_Call));
 369       Analyze_And_Resolve (N, Typ);
 370    end Process_Partition_Id;
 371
 372    ----------------------------------
 373    -- Process_Remote_AST_Attribute --
 374    ----------------------------------
 375
 376    procedure Process_Remote_AST_Attribute
 377      (N        : Node_Id;
 378       New_Type : Entity_Id)
 379    is
 380       Loc                   : constant Source_Ptr := Sloc (N);
 381       Remote_Subp           : Entity_Id;
 382       Tick_Access_Conv_Call : Node_Id;
 383       Remote_Subp_Decl      : Node_Id;
 384       RS_Pkg_Specif         : Node_Id;
 385       RS_Pkg_E              : Entity_Id;
 386       RAS_Type              : Entity_Id := New_Type;
 387       Async_E               : Entity_Id;
 388       All_Calls_Remote_E    : Entity_Id;
 389       Attribute_Subp        : Entity_Id;
 390
 391    begin
 392       --  Check if we have to expand the access attribute
 393
 394       Remote_Subp := Entity (Prefix (N));
 395
 396       if not Expander_Active or else Get_PCS_Name = Name_No_DSA then
 397          return;
 398       end if;
 399
 400       if Ekind (RAS_Type) /= E_Record_Type then
 401          RAS_Type := Equivalent_Type (RAS_Type);
 402       end if;
 403
 404       Attribute_Subp := TSS (RAS_Type, TSS_RAS_Access);
 405       pragma Assert (Present (Attribute_Subp));
 406       Remote_Subp_Decl := Unit_Declaration_Node (Remote_Subp);
 407
 408       if Nkind (Remote_Subp_Decl) = N_Subprogram_Body then
 409          Remote_Subp := Corresponding_Spec (Remote_Subp_Decl);
 410          Remote_Subp_Decl := Unit_Declaration_Node (Remote_Subp);
 411       end if;
 412
 413       RS_Pkg_Specif := Parent (Remote_Subp_Decl);
 414       RS_Pkg_E := Defining_Entity (RS_Pkg_Specif);
 415
 416       Async_E :=
 417         Boolean_Literals (Ekind (Remote_Subp) = E_Procedure
 418                             and then Is_Asynchronous (Remote_Subp));
 419
 420       All_Calls_Remote_E :=
 421         Boolean_Literals (Has_All_Calls_Remote (RS_Pkg_E));
 422
 423       Tick_Access_Conv_Call :=
 424         Make_Function_Call (Loc,
 425           Name                   => New_Occurrence_Of (Attribute_Subp, Loc),
 426           Parameter_Associations =>
 427             New_List (
 428               Make_String_Literal (Loc,
 429                 Strval => Full_Qualified_Name (RS_Pkg_E)),
 430               Build_Subprogram_Id (Loc, Remote_Subp),
 431               New_Occurrence_Of (Async_E, Loc),
 432               New_Occurrence_Of (All_Calls_Remote_E, Loc)));
 433
 434       Rewrite (N, Tick_Access_Conv_Call);
 435       Analyze_And_Resolve (N, RAS_Type);
 436    end Process_Remote_AST_Attribute;
 437
 438    ------------------------------------
 439    -- Process_Remote_AST_Declaration --
 440    ------------------------------------
 441
 442    procedure Process_Remote_AST_Declaration (N : Node_Id) is
 443       Loc       : constant Source_Ptr := Sloc (N);
 444       User_Type : constant Node_Id    := Defining_Identifier (N);
 445       Scop      : constant Entity_Id  := Scope (User_Type);
 446       Is_RCI    : constant Boolean    := Is_Remote_Call_Interface (Scop);
 447       Is_RT     : constant Boolean    := Is_Remote_Types (Scop);
 448       Type_Def  : constant Node_Id    := Type_Definition (N);
 449       Parameter : Node_Id;
 450
 451       Is_Degenerate : Boolean;
 452       --  True iff this RAS has an access formal parameter (see
 453       --  Exp_Dist.Add_RAS_Dereference_TSS for details).
 454
 455       Subpkg      : constant Entity_Id :=
 456                       Make_Defining_Identifier (Loc,
 457                         New_Internal_Name ('S'));
 458       Subpkg_Decl : Node_Id;
 459       Subpkg_Body : Node_Id;
 460       Vis_Decls   : constant List_Id := New_List;
 461       Priv_Decls  : constant List_Id := New_List;
 462
 463       Obj_Type : constant Entity_Id :=
 464                     Make_Defining_Identifier (Loc,
 465                       New_External_Name (Chars (User_Type), 'R'));
 466
 467       Full_Obj_Type : constant Entity_Id :=
 468                         Make_Defining_Identifier (Loc,
 469                           Chars (Obj_Type));
 470
 471       RACW_Type : constant Entity_Id :=
 472                     Make_Defining_Identifier (Loc,
 473                       New_External_Name (Chars (User_Type), 'P'));
 474
 475       Fat_Type : constant Entity_Id :=
 476                    Make_Defining_Identifier (Loc,
 477                      Chars (User_Type));
 478
 479       Fat_Type_Decl : Node_Id;
 480
 481    begin
 482       Is_Degenerate := False;
 483       Parameter := First (Parameter_Specifications (Type_Def));
 484       while Present (Parameter) loop
 485          if Nkind (Parameter_Type (Parameter)) = N_Access_Definition then
 486             Error_Msg_N ("formal parameter& has anonymous access type?",
 487               Defining_Identifier (Parameter));
 488             Is_Degenerate := True;
 489             exit;
 490          end if;
 491
 492          Next (Parameter);
 493       end loop;
 494
 495       if Is_Degenerate then
 496          Error_Msg_NE
 497            ("remote access-to-subprogram type& can only be null?",
 498             Defining_Identifier (Parameter), User_Type);
 499
 500          --  The only legal value for a RAS with a formal parameter of an
 501          --  anonymous access type is null, because it cannot be subtype-
 502          --  conformant with any legal remote subprogram declaration. In this
 503          --  case, we cannot generate a corresponding primitive operation.
 504
 505       end if;
 506
 507       if Get_PCS_Name = Name_No_DSA then
 508          return;
 509       end if;
 510
 511       --  The tagged private type, primitive operation and RACW type associated
 512       --  with a RAS need to all be declared in a subpackage of the one that
 513       --  contains the RAS declaration, because the primitive of the object
 514       --  type, and the associated primitive of the stub type, need to be
 515       --  dispatching operations of these types, and the profile of the RAS
 516       --  might contain tagged types declared in the same scope.
 517
 518       Append_To (Vis_Decls,
 519         Make_Private_Type_Declaration (Loc,
 520           Defining_Identifier => Obj_Type,
 521           Abstract_Present => True,
 522           Tagged_Present   => True,
 523           Limited_Present  => True));
 524
 525       Append_To (Priv_Decls,
 526         Make_Full_Type_Declaration (Loc,
 527           Defining_Identifier => Full_Obj_Type,
 528           Type_Definition     =>
 529             Make_Record_Definition (Loc,
 530               Abstract_Present => True,
 531               Tagged_Present   => True,
 532               Limited_Present  => True,
 533               Null_Present     => True,
 534               Component_List   => Empty)));
 535
 536       --  Trick semantic analysis into swapping the public and full view when
 537       --  freezing the public view.
 538
 539       Set_Comes_From_Source (Full_Obj_Type, True);
 540
 541       if not Is_Degenerate then
 542          Append_To (Vis_Decls,
 543            Make_Abstract_Subprogram_Declaration (Loc,
 544              Specification => Build_RAS_Primitive_Specification (
 545                Subp_Spec          => Type_Def,
 546                Remote_Object_Type => Obj_Type)));
 547       end if;
 548
 549       Append_To (Vis_Decls,
 550         Make_Full_Type_Declaration (Loc,
 551           Defining_Identifier => RACW_Type,
 552           Type_Definition     =>
 553             Make_Access_To_Object_Definition (Loc,
 554               All_Present => True,
 555               Subtype_Indication =>
 556                 Make_Attribute_Reference (Loc,
 557                   Prefix         => New_Occurrence_Of (Obj_Type, Loc),
 558                   Attribute_Name => Name_Class))));
 559
 560       Set_Is_Remote_Call_Interface (RACW_Type, Is_RCI);
 561       Set_Is_Remote_Types (RACW_Type, Is_RT);
 562
 563       Subpkg_Decl :=
 564         Make_Package_Declaration (Loc,
 565           Make_Package_Specification (Loc,
 566             Defining_Unit_Name   => Subpkg,
 567             Visible_Declarations => Vis_Decls,
 568             Private_Declarations => Priv_Decls,
 569             End_Label            => New_Occurrence_Of (Subpkg, Loc)));
 570
 571       Set_Is_Remote_Call_Interface (Subpkg, Is_RCI);
 572       Set_Is_Remote_Types (Subpkg, Is_RT);
 573       Insert_After_And_Analyze (N, Subpkg_Decl);
 574
 575       --  Generate package body to receive RACW calling stubs
 576
 577       --  Note: Analyze_Declarations has an absolute requirement that the
 578       --  declaration list be non-empty, so provide dummy null statement here.
 579
 580       Subpkg_Body :=
 581         Make_Package_Body (Loc,
 582           Defining_Unit_Name => Make_Defining_Identifier (Loc, Chars (Subpkg)),
 583           Declarations       => New_List (Make_Null_Statement (Loc)));
 584       Insert_After_And_Analyze (Subpkg_Decl, Subpkg_Body);
 585
 586       --  Many parts of the analyzer and expander expect
 587       --  that the fat pointer type used to implement remote
 588       --  access to subprogram types be a record.
 589       --  Note: The structure of this type must be kept consistent
 590       --  with the code generated by Remote_AST_Null_Value for the
 591       --  corresponding 'null' expression.
 592
 593       Fat_Type_Decl := Make_Full_Type_Declaration (Loc,
 594         Defining_Identifier => Fat_Type,
 595         Type_Definition     =>
 596           Make_Record_Definition (Loc,
 597             Component_List =>
 598               Make_Component_List (Loc,
 599                 Component_Items => New_List (
 600                   Make_Component_Declaration (Loc,
 601                     Defining_Identifier =>
 602                       Make_Defining_Identifier (Loc, Name_Ras),
 603                     Component_Definition =>
 604                       Make_Component_Definition (Loc,
 605                         Aliased_Present     => False,
 606                         Subtype_Indication  =>
 607                           New_Occurrence_Of (RACW_Type, Loc)))))));
 608
 609       Set_Equivalent_Type (User_Type, Fat_Type);
 610       Set_Corresponding_Remote_Type (Fat_Type, User_Type);
 611       Insert_After_And_Analyze (Subpkg_Body, Fat_Type_Decl);
 612
 613       --  The reason we suppress the initialization procedure is that we know
 614       --  that no initialization is required (even if Initialize_Scalars mode
 615       --  is active), and there are order of elaboration problems if we do try
 616       --  to generate an init proc for this created record type.
 617
 618       Set_Suppress_Init_Proc (Fat_Type);
 619
 620       if Expander_Active then
 621          Add_RAST_Features (Parent (User_Type));
 622       end if;
 623    end Process_Remote_AST_Declaration;
 624
 625    -----------------------
 626    -- RAS_E_Dereference --
 627    -----------------------
 628
 629    procedure RAS_E_Dereference (Pref : Node_Id) is
 630       Loc             : constant Source_Ptr := Sloc (Pref);
 631       Call_Node       : Node_Id;
 632       New_Type        : constant Entity_Id := Etype (Pref);
 633       Explicit_Deref  : constant Node_Id   := Parent (Pref);
 634       Deref_Subp_Call : constant Node_Id   := Parent (Explicit_Deref);
 635       Deref_Proc      : Entity_Id;
 636       Params          : List_Id;
 637
 638    begin
 639       if Nkind (Deref_Subp_Call) = N_Procedure_Call_Statement then
 640          Params := Parameter_Associations (Deref_Subp_Call);
 641
 642          if Present (Params) then
 643             Prepend (Pref, Params);
 644          else
 645             Params := New_List (Pref);
 646          end if;
 647
 648       elsif Nkind (Deref_Subp_Call) = N_Indexed_Component then
 649          Params := Expressions (Deref_Subp_Call);
 650
 651          if Present (Params) then
 652             Prepend (Pref, Params);
 653          else
 654             Params := New_List (Pref);
 655          end if;
 656
 657       else
 658          --  Context is not a call
 659
 660          return;
 661       end if;
 662
 663       if not Expander_Active or else Get_PCS_Name = Name_No_DSA then
 664          return;
 665       end if;
 666
 667       Deref_Proc := TSS (New_Type, TSS_RAS_Dereference);
 668       pragma Assert (Present (Deref_Proc));
 669
 670       if Ekind (Deref_Proc) = E_Function then
 671          Call_Node :=
 672            Make_Function_Call (Loc,
 673               Name                   => New_Occurrence_Of (Deref_Proc, Loc),
 674               Parameter_Associations => Params);
 675       else
 676          Call_Node :=
 677            Make_Procedure_Call_Statement (Loc,
 678               Name                   => New_Occurrence_Of (Deref_Proc, Loc),
 679               Parameter_Associations => Params);
 680       end if;
 681
 682       Rewrite (Deref_Subp_Call, Call_Node);
 683       Analyze (Deref_Subp_Call);
 684    end RAS_E_Dereference;
 685
 686    ------------------------------
 687    -- Remote_AST_E_Dereference --
 688    ------------------------------
 689
 690    function Remote_AST_E_Dereference (P : Node_Id) return Boolean is
 691       ET : constant Entity_Id  := Etype (P);
 692
 693    begin
 694       --  Perform the changes only on original dereferences, and only if
 695       --  we are generating code.
 696
 697       if Comes_From_Source (P)
 698         and then Is_Record_Type (ET)
 699         and then (Is_Remote_Call_Interface (ET)
 700                    or else Is_Remote_Types (ET))
 701         and then Present (Corresponding_Remote_Type (ET))
 702         and then Nkind_In (Parent (Parent (P)), N_Procedure_Call_Statement,
 703                                                 N_Indexed_Component)
 704         and then Expander_Active
 705       then
 706          RAS_E_Dereference (P);
 707          return True;
 708       else
 709          return False;
 710       end if;
 711    end Remote_AST_E_Dereference;
 712
 713    ------------------------------
 714    -- Remote_AST_I_Dereference --
 715    ------------------------------
 716
 717    function Remote_AST_I_Dereference (P : Node_Id) return Boolean is
 718       ET     : constant Entity_Id  := Etype (P);
 719       Deref  : Node_Id;
 720
 721    begin
 722       if Comes_From_Source (P)
 723         and then (Is_Remote_Call_Interface (ET)
 724                    or else Is_Remote_Types (ET))
 725         and then Present (Corresponding_Remote_Type (ET))
 726         and then Ekind (Entity (P)) /= E_Function
 727       then
 728          Deref :=
 729            Make_Explicit_Dereference (Sloc (P),
 730              Prefix => Relocate_Node (P));
 731          Rewrite (P, Deref);
 732          Set_Etype (P, ET);
 733          RAS_E_Dereference (Prefix (P));
 734          return True;
 735       end if;
 736
 737       return False;
 738    end Remote_AST_I_Dereference;
 739
 740    ---------------------------
 741    -- Remote_AST_Null_Value --
 742    ---------------------------
 743
 744    function Remote_AST_Null_Value
 745      (N   : Node_Id;
 746       Typ : Entity_Id) return Boolean
 747    is
 748       Loc         : constant Source_Ptr := Sloc (N);
 749       Target_Type : Entity_Id;
 750
 751    begin
 752       if not Expander_Active or else Get_PCS_Name = Name_No_DSA then
 753          return False;
 754
 755       elsif Ekind (Typ) = E_Access_Subprogram_Type
 756         and then (Is_Remote_Call_Interface (Typ)
 757                     or else Is_Remote_Types (Typ))
 758         and then Comes_From_Source (N)
 759         and then Expander_Active
 760       then
 761          --  Any null that comes from source and is of the RAS type must
 762          --  be expanded, except if expansion is not active (nothing
 763          --  gets expanded into the equivalent record type).
 764
 765          Target_Type := Equivalent_Type (Typ);
 766
 767       elsif Ekind (Typ) = E_Record_Type
 768         and then Present (Corresponding_Remote_Type (Typ))
 769       then
 770          --  This is a record type representing a RAS type, this must be
 771          --  expanded.
 772
 773          Target_Type := Typ;
 774
 775       else
 776          --  We do not have to handle this case
 777
 778          return False;
 779       end if;
 780
 781       Rewrite (N,
 782         Make_Aggregate (Loc,
 783           Component_Associations => New_List (
 784             Make_Component_Association (Loc,
 785               Choices => New_List (Make_Identifier (Loc, Name_Ras)),
 786               Expression => Make_Null (Loc)))));
 787       Analyze_And_Resolve (N, Target_Type);
 788       return True;
 789    end Remote_AST_Null_Value;
 790
 791 end Sem_Dist;