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