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