gcc/ada/exp_dist.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                              E X P_ D I S T                              --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2004 Free Software Foundation, Inc.          --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  19 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, USA.                                                      --
  21 --                                                                          --
  22 -- GNAT was originally developed  by the GNAT team at  New York University. --
  23 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  24 --                                                                          --
  25 ------------------------------------------------------------------------------
  26
  27 with Atree;       use Atree;
  28 with Einfo;       use Einfo;
  29 with Elists;      use Elists;
  30 with Exp_Strm;    use Exp_Strm;
  31 with Exp_Tss;     use Exp_Tss;
  32 with Exp_Util;    use Exp_Util;
  33 with GNAT.HTable; use GNAT.HTable;
  34 with Lib;         use Lib;
  35 with Namet;       use Namet;
  36 with Nlists;      use Nlists;
  37 with Nmake;       use Nmake;
  38 with Opt;         use Opt;
  39 with Rtsfind;     use Rtsfind;
  40 with Sem;         use Sem;
  41 with Sem_Ch3;     use Sem_Ch3;
  42 with Sem_Ch8;     use Sem_Ch8;
  43 with Sem_Dist;    use Sem_Dist;
  44 with Sem_Util;    use Sem_Util;
  45 with Sinfo;       use Sinfo;
  46 with Snames;      use Snames;
  47 with Stand;       use Stand;
  48 with Stringt;     use Stringt;
  49 with Tbuild;      use Tbuild;
  50 with Uintp;       use Uintp;
  51 with Uname;       use Uname;
  52
  53 package body Exp_Dist is
  54
  55    --  The following model has been used to implement distributed objects:
  56    --  given a designated type D and a RACW type R, then a record of the
  57    --  form:
  58
  59    --    type Stub is tagged record
  60    --       [...declaration similar to s-parint.ads RACW_Stub_Type...]
  61    --    end record;
  62
  63    --  is built. This type has two properties:
  64
  65    --    1) Since it has the same structure than RACW_Stub_Type, it can be
  66    --       converted to and from this type to make it suitable for
  67    --       System.Partition_Interface.Get_Unique_Remote_Pointer in order
  68    --       to avoid memory leaks when the same remote object arrive on the
  69    --       same partition through several paths;
  70
  71    --    2) It also has the same dispatching table as the designated type D,
  72    --       and thus can be used as an object designated by a value of type
  73    --       R on any partition other than the one on which the object has
  74    --       been created, since only dispatching calls will be performed and
  75    --       the fields themselves will not be used. We call Derive_Subprograms
  76    --       to fake half a derivation to ensure that the subprograms do have
  77    --       the same dispatching table.
  78
  79    First_RCI_Subprogram_Id : constant := 2;
  80    --  RCI subprograms are numbered starting at 2. The RCI receiver for
  81    --  an RCI package can thus identify calls received through remote
  82    --  access-to-subprogram dereferences by the fact that they have a
  83    --  (primitive) subprogram id of 0, and 1 is used for the internal
  84    --  RAS information lookup operation.
  85
  86    -----------------------
  87    -- Local subprograms --
  88    -----------------------
  89
  90    procedure Add_RAS_Proxy_And_Analyze
  91      (Decls              :     List_Id;
  92       Vis_Decl           :     Node_Id;
  93       All_Calls_Remote_E :     Entity_Id;
  94       Proxy_Object_Addr  : out Entity_Id);
  95    --  Add the proxy type necessary to call the subprogram declared
  96    --  by Vis_Decl through a remote access to subprogram type.
  97    --  All_Calls_Remote_E must be Standard_True if a pragma All_Calls_Remote
  98    --  applies, Standard_False otherwise. The new proxy type is appended
  99    --  to Decls. Proxy_Object_Addr is a constant of type System.Address that
 100    --  designates an instance of the proxy object.
 101
 102    function Build_Remote_Subprogram_Proxy_Type
 103      (Loc            : Source_Ptr;
 104       ACR_Expression : Node_Id) return Node_Id;
 105    --  Build and return a tagged record type definition for an RCI
 106    --  subprogram proxy type.
 107    --  ACR_Expression is use as the initialization value for
 108    --  the All_Calls_Remote component.
 109
 110    function Get_Subprogram_Id (E : Entity_Id) return Int;
 111    --  Given a subprogram defined in a RCI package, get its subprogram id
 112    --  which will be used for remote calls.
 113
 114    function Build_Get_Unique_RP_Call
 115      (Loc       : Source_Ptr;
 116       Pointer   : Entity_Id;
 117       Stub_Type : Entity_Id) return List_Id;
 118    --  Build a call to Get_Unique_Remote_Pointer (Pointer),
 119    --  followed by a tag fixup (Get_Unique_Remote_Pointer may have
 120    --  changed Pointer'Tag to RACW_Stub_Type'Tag, while the desired
 121    --  tag is that of Stub_Type).
 122
 123    procedure Build_General_Calling_Stubs
 124      (Decls                     : List_Id;
 125       Statements                : List_Id;
 126       Target_Partition          : Entity_Id;
 127       RPC_Receiver              : Node_Id;
 128       Subprogram_Id             : Node_Id;
 129       Asynchronous              : Node_Id := Empty;
 130       Is_Known_Asynchronous     : Boolean := False;
 131       Is_Known_Non_Asynchronous : Boolean := False;
 132       Is_Function               : Boolean;
 133       Spec                      : Node_Id;
 134       Stub_Type                 : Entity_Id := Empty;
 135       RACW_Type                 : Entity_Id := Empty;
 136       Nod                       : Node_Id);
 137    --  Build calling stubs for general purpose. The parameters are:
 138    --    Decls             : a place to put declarations
 139    --    Statements        : a place to put statements
 140    --    Target_Partition  : a node containing the target partition that must
 141    --                        be a N_Defining_Identifier
 142    --    RPC_Receiver      : a node containing the RPC receiver
 143    --    Subprogram_Id     : a node containing the subprogram ID
 144    --    Asynchronous      : True if an APC must be made instead of an RPC.
 145    --                        The value needs not be supplied if one of the
 146    --                        Is_Known_... is True.
 147    --    Is_Known_Async... : True if we know that this is asynchronous
 148    --    Is_Known_Non_A... : True if we know that this is not asynchronous
 149    --    Spec              : a node with a Parameter_Specifications and
 150    --                        a Subtype_Mark if applicable
 151    --    Stub_Type         : in case of RACW stubs, parameters of type access
 152    --                        to Stub_Type will be marshalled using the
 153    --                        address of the object (the addr field) rather
 154    --                        than using the 'Write on the stub itself
 155    --    Nod               : used to provide sloc for generated code
 156
 157    function Build_Subprogram_Calling_Stubs
 158      (Vis_Decl                 : Node_Id;
 159       Subp_Id                  : Int;
 160       Asynchronous             : Boolean;
 161       Dynamically_Asynchronous : Boolean   := False;
 162       Stub_Type                : Entity_Id := Empty;
 163       RACW_Type                : Entity_Id := Empty;
 164       Locator                  : Entity_Id := Empty;
 165       New_Name                 : Name_Id   := No_Name) return Node_Id;
 166    --  Build the calling stub for a given subprogram with the subprogram ID
 167    --  being Subp_Id. If Stub_Type is given, then the "addr" field of
 168    --  parameters of this type will be marshalled instead of the object
 169    --  itself. It will then be converted into Stub_Type before performing
 170    --  the real call. If Dynamically_Asynchronous is True, then it will be
 171    --  computed at run time whether the call is asynchronous or not.
 172    --  Otherwise, the value of the formal Asynchronous will be used.
 173    --  If Locator is not Empty, it will be used instead of RCI_Cache. If
 174    --  New_Name is given, then it will be used instead of the original name.
 175
 176    function Build_Subprogram_Receiving_Stubs
 177      (Vis_Decl                 : Node_Id;
 178       Asynchronous             : Boolean;
 179       Dynamically_Asynchronous : Boolean   := False;
 180       Stub_Type                : Entity_Id := Empty;
 181       RACW_Type                : Entity_Id := Empty;
 182       Parent_Primitive         : Entity_Id := Empty) return Node_Id;
 183    --  Build the receiving stub for a given subprogram. The subprogram
 184    --  declaration is also built by this procedure, and the value returned
 185    --  is a N_Subprogram_Body. If a parameter of type access to Stub_Type is
 186    --  found in the specification, then its address is read from the stream
 187    --  instead of the object itself and converted into an access to
 188    --  class-wide type before doing the real call using any of the RACW type
 189    --  pointing on the designated type.
 190
 191    function Build_RPC_Receiver_Specification
 192      (RPC_Receiver     : Entity_Id;
 193       Stream_Parameter : Entity_Id;
 194       Result_Parameter : Entity_Id) return Node_Id;
 195    --  Make a subprogram specification for an RPC receiver,
 196    --  with the given defining unit name and formal parameters.
 197
 198    function Build_Ordered_Parameters_List (Spec : Node_Id) return List_Id;
 199    --  Return an ordered parameter list: unconstrained parameters are put
 200    --  at the beginning of the list and constrained ones are put after. If
 201    --  there are no parameters, an empty list is returned. Special case:
 202    --  the controlling formal of the equivalent RACW operation for a RAS
 203    --  type is always left in first position.
 204
 205    procedure Add_Calling_Stubs_To_Declarations
 206      (Pkg_Spec : Node_Id;
 207       Decls    : List_Id);
 208    --  Add calling stubs to the declarative part
 209
 210    procedure Add_Receiving_Stubs_To_Declarations
 211      (Pkg_Spec : Node_Id;
 212       Decls    : List_Id);
 213    --  Add receiving stubs to the declarative part
 214
 215    procedure Add_RAS_Dereference_TSS (N : Node_Id);
 216    --  Add a subprogram body for RAS Dereference TSS
 217
 218    procedure Add_RAS_Access_TSS (N : Node_Id);
 219    --  Add a subprogram body for RAS Access TSS
 220
 221    function Could_Be_Asynchronous (Spec : Node_Id) return Boolean;
 222    --  Return True if nothing prevents the program whose specification is
 223    --  given to be asynchronous (i.e. no out parameter).
 224
 225    procedure Get_Pkg_Name_String (Decl_Node : Node_Id);
 226    --  Retrieve the fully expanded name of the library unit declared by decl
 227    --  into the name buffer.
 228
 229    function Pack_Entity_Into_Stream_Access
 230      (Loc    : Source_Ptr;
 231       Stream : Node_Id;
 232       Object : Entity_Id;
 233       Etyp   : Entity_Id := Empty) return Node_Id;
 234    --  Pack Object (of type Etyp) into Stream. If Etyp is not given,
 235    --  then Etype (Object) will be used if present. If the type is
 236    --  constrained, then 'Write will be used to output the object,
 237    --  If the type is unconstrained, 'Output will be used.
 238
 239    function Pack_Node_Into_Stream
 240      (Loc    : Source_Ptr;
 241       Stream : Entity_Id;
 242       Object : Node_Id;
 243       Etyp   : Entity_Id) return Node_Id;
 244    --  Similar to above, with an arbitrary node instead of an entity
 245
 246    function Pack_Node_Into_Stream_Access
 247      (Loc    : Source_Ptr;
 248       Stream : Node_Id;
 249       Object : Node_Id;
 250       Etyp   : Entity_Id) return Node_Id;
 251    --  Similar to above, with Stream instead of Stream'Access
 252
 253    function Scope_Of_Spec (Spec : Node_Id) return Entity_Id;
 254    --  Return the scope represented by a given spec
 255
 256    function Need_Extra_Constrained (Parameter : Node_Id) return Boolean;
 257    --  Return True if the current parameter needs an extra formal to reflect
 258    --  its constrained status.
 259
 260    function Is_RACW_Controlling_Formal
 261      (Parameter : Node_Id; Stub_Type : Entity_Id) return Boolean;
 262    --  Return True if the current parameter is a controlling formal argument
 263    --  of type Stub_Type or access to Stub_Type.
 264
 265    type Stub_Structure is record
 266       Stub_Type           : Entity_Id;
 267       Stub_Type_Access    : Entity_Id;
 268       Object_RPC_Receiver : Entity_Id;
 269       RPC_Receiver_Stream : Entity_Id;
 270       RPC_Receiver_Result : Entity_Id;
 271       RACW_Type           : Entity_Id;
 272    end record;
 273    --  This structure is necessary because of the two phases analysis of
 274    --  a RACW declaration occurring in the same Remote_Types package as the
 275    --  designated type. RACW_Type is any of the RACW types pointing on this
 276    --  designated type, it is used here to save an anonymous type creation
 277    --  for each primitive operation.
 278
 279    Empty_Stub_Structure : constant Stub_Structure :=
 280      (Empty, Empty, Empty, Empty, Empty, Empty);
 281
 282    type Hash_Index is range 0 .. 50;
 283    function Hash (F : Entity_Id) return Hash_Index;
 284
 285    package Stubs_Table is
 286       new Simple_HTable (Header_Num => Hash_Index,
 287                          Element    => Stub_Structure,
 288                          No_Element => Empty_Stub_Structure,
 289                          Key        => Entity_Id,
 290                          Hash       => Hash,
 291                          Equal      => "=");
 292    --  Mapping between a RACW designated type and its stub type
 293
 294    package Asynchronous_Flags_Table is
 295       new Simple_HTable (Header_Num => Hash_Index,
 296                          Element    => Entity_Id,
 297                          No_Element => Empty,
 298                          Key        => Entity_Id,
 299                          Hash       => Hash,
 300                          Equal      => "=");
 301    --  Mapping between a RACW type and a constant having the value True
 302    --  if the RACW is asynchronous and False otherwise.
 303
 304    package RCI_Locator_Table is
 305       new Simple_HTable (Header_Num => Hash_Index,
 306                          Element    => Entity_Id,
 307                          No_Element => Empty,
 308                          Key        => Entity_Id,
 309                          Hash       => Hash,
 310                          Equal      => "=");
 311    --  Mapping between a RCI package on which All_Calls_Remote applies and
 312    --  the generic instantiation of RCI_Locator for this package.
 313
 314    package RCI_Calling_Stubs_Table is
 315       new Simple_HTable (Header_Num => Hash_Index,
 316                          Element    => Entity_Id,
 317                          No_Element => Empty,
 318                          Key        => Entity_Id,
 319                          Hash       => Hash,
 320                          Equal      => "=");
 321    --  Mapping between a RCI subprogram and the corresponding calling stubs
 322
 323    procedure Add_Stub_Type
 324      (Designated_Type     : Entity_Id;
 325       RACW_Type           : Entity_Id;
 326       Decls               : List_Id;
 327       Stub_Type           : out Entity_Id;
 328       Stub_Type_Access    : out Entity_Id;
 329       Object_RPC_Receiver : out Entity_Id;
 330       Existing            : out Boolean);
 331    --  Add the declaration of the stub type, the access to stub type and the
 332    --  object RPC receiver at the end of Decls. If these already exist,
 333    --  then nothing is added in the tree but the right values are returned
 334    --  anyhow and Existing is set to True.
 335
 336    procedure Add_RACW_Asynchronous_Flag
 337      (Declarations : List_Id;
 338       RACW_Type    : Entity_Id);
 339    --  Declare a boolean constant associated with RACW_Type whose value
 340    --  indicates at run time whether a pragma Asynchronous applies to it.
 341
 342    procedure Add_RACW_Read_Attribute
 343      (RACW_Type           : Entity_Id;
 344       Stub_Type           : Entity_Id;
 345       Stub_Type_Access    : Entity_Id;
 346       Declarations        : List_Id);
 347    --  Add Read attribute in Decls for the RACW type. The Read attribute
 348    --  is added right after the RACW_Type declaration while the body is
 349    --  inserted after Declarations.
 350
 351    procedure Add_RACW_Write_Attribute
 352      (RACW_Type           : Entity_Id;
 353       Stub_Type           : Entity_Id;
 354       Stub_Type_Access    : Entity_Id;
 355       Object_RPC_Receiver : Entity_Id;
 356       Declarations        : List_Id);
 357    --  Same thing for the Write attribute
 358
 359    procedure Add_RACW_Read_Write_Attributes
 360      (RACW_Type           : Entity_Id;
 361       Stub_Type           : Entity_Id;
 362       Stub_Type_Access    : Entity_Id;
 363       Object_RPC_Receiver : Entity_Id;
 364       Declarations        : List_Id);
 365    --  Add Read and Write attributes declarations and bodies for a given
 366    --  RACW type. The declarations are added just after the declaration
 367    --  of the RACW type itself, while the bodies are inserted at the end
 368    --  of Decls.
 369
 370    function RCI_Package_Locator
 371      (Loc          : Source_Ptr;
 372       Package_Spec : Node_Id) return Node_Id;
 373    --  Instantiate the generic package RCI_Locator in order to locate the
 374    --  RCI package whose spec is given as argument.
 375
 376    function Make_Tag_Check (Loc : Source_Ptr; N : Node_Id) return Node_Id;
 377    --  Surround a node N by a tag check, as in:
 378    --      begin
 379    --         <N>;
 380    --      exception
 381    --         when E : Ada.Tags.Tag_Error =>
 382    --           Raise_Exception (Program_Error'Identity,
 383    --                            Exception_Message (E));
 384    --      end;
 385
 386    function Input_With_Tag_Check
 387      (Loc      : Source_Ptr;
 388       Var_Type : Entity_Id;
 389       Stream   : Entity_Id) return Node_Id;
 390    --  Return a function with the following form:
 391    --    function R return Var_Type is
 392    --    begin
 393    --       return Var_Type'Input (S);
 394    --    exception
 395    --       when E : Ada.Tags.Tag_Error =>
 396    --           Raise_Exception (Program_Error'Identity,
 397    --                            Exception_Message (E));
 398    --    end R;
 399
 400    ------------------------------------
 401    -- Local variables and structures --
 402    ------------------------------------
 403
 404    RCI_Cache : Node_Id;
 405
 406    Output_From_Constrained : constant array (Boolean) of Name_Id :=
 407      (False => Name_Output,
 408       True  => Name_Write);
 409    --  The attribute to choose depending on the fact that the parameter
 410    --  is constrained or not. There is no such thing as Input_From_Constrained
 411    --  since this require separate mechanisms ('Input is a function while
 412    --  'Read is a procedure).
 413
 414    ---------------------------------------
 415    -- Add_Calling_Stubs_To_Declarations --
 416    ---------------------------------------
 417
 418    procedure Add_Calling_Stubs_To_Declarations
 419      (Pkg_Spec : Node_Id;
 420       Decls    : List_Id)
 421    is
 422       Current_Subprogram_Number : Int := First_RCI_Subprogram_Id;
 423       --  Subprogram id 0 is reserved for calls received from
 424       --  remote access-to-subprogram dereferences.
 425
 426       Current_Declaration       : Node_Id;
 427       Loc                       : constant Source_Ptr := Sloc (Pkg_Spec);
 428       RCI_Instantiation         : Node_Id;
 429       Subp_Stubs                : Node_Id;
 430
 431    begin
 432       --  The first thing added is an instantiation of the generic package
 433       --  System.Partition_interface.RCI_Locator with the name of this
 434       --  remote package. This will act as an interface with the name server
 435       --  to determine the Partition_ID and the RPC_Receiver for the
 436       --  receiver of this package.
 437
 438       RCI_Instantiation := RCI_Package_Locator (Loc, Pkg_Spec);
 439       RCI_Cache         := Defining_Unit_Name (RCI_Instantiation);
 440
 441       Append_To (Decls, RCI_Instantiation);
 442       Analyze (RCI_Instantiation);
 443
 444       --  For each subprogram declaration visible in the spec, we do
 445       --  build a body. We also increment a counter to assign a different
 446       --  Subprogram_Id to each subprograms. The receiving stubs processing
 447       --  do use the same mechanism and will thus assign the same Id and
 448       --  do the correct dispatching.
 449
 450       Current_Declaration := First (Visible_Declarations (Pkg_Spec));
 451       while Current_Declaration /= Empty loop
 452          if Nkind (Current_Declaration) = N_Subprogram_Declaration
 453            and then Comes_From_Source (Current_Declaration)
 454          then
 455             pragma Assert (Current_Subprogram_Number =
 456               Get_Subprogram_Id (Defining_Unit_Name (Specification (
 457                 Current_Declaration))));
 458
 459             Subp_Stubs :=
 460               Build_Subprogram_Calling_Stubs (
 461                 Vis_Decl     => Current_Declaration,
 462                 Subp_Id      => Current_Subprogram_Number,
 463                 Asynchronous =>
 464                   Nkind (Specification (Current_Declaration)) =
 465                     N_Procedure_Specification
 466                   and then
 467                     Is_Asynchronous (Defining_Unit_Name (Specification
 468                       (Current_Declaration))));
 469
 470             Append_To (Decls, Subp_Stubs);
 471             Analyze (Subp_Stubs);
 472
 473             Current_Subprogram_Number := Current_Subprogram_Number + 1;
 474          end if;
 475
 476          Next (Current_Declaration);
 477       end loop;
 478    end Add_Calling_Stubs_To_Declarations;
 479
 480    --------------------------------
 481    -- Add_RACW_Asynchronous_Flag --
 482    --------------------------------
 483
 484    procedure Add_RACW_Asynchronous_Flag
 485      (Declarations : List_Id;
 486       RACW_Type    : Entity_Id)
 487    is
 488       Loc : constant Source_Ptr := Sloc (RACW_Type);
 489
 490       Asynchronous_Flag : constant Entity_Id :=
 491                             Make_Defining_Identifier (Loc,
 492                               New_External_Name (Chars (RACW_Type), 'A'));
 493
 494    begin
 495       --  Declare the asynchronous flag. This flag will be changed to True
 496       --  whenever it is known that the RACW type is asynchronous.
 497
 498       Append_To (Declarations,
 499         Make_Object_Declaration (Loc,
 500           Defining_Identifier => Asynchronous_Flag,
 501           Constant_Present    => True,
 502           Object_Definition   => New_Occurrence_Of (Standard_Boolean, Loc),
 503           Expression          => New_Occurrence_Of (Standard_False, Loc)));
 504
 505       Asynchronous_Flags_Table.Set (RACW_Type, Asynchronous_Flag);
 506    end Add_RACW_Asynchronous_Flag;
 507
 508    -----------------------
 509    -- Add_RACW_Features --
 510    -----------------------
 511
 512    procedure Add_RACW_Features (RACW_Type : Entity_Id)
 513    is
 514       Desig : constant Entity_Id :=
 515                 Etype (Designated_Type (RACW_Type));
 516       Decls : List_Id :=
 517                 List_Containing (Declaration_Node (RACW_Type));
 518
 519       Same_Scope : constant Boolean :=
 520                      Scope (Desig) = Scope (RACW_Type);
 521
 522       Stub_Type           : Entity_Id;
 523       Stub_Type_Access    : Entity_Id;
 524       Object_RPC_Receiver : Entity_Id;
 525       Existing            : Boolean;
 526
 527    begin
 528       if not Expander_Active then
 529          return;
 530       end if;
 531
 532       if Same_Scope then
 533
 534          --  We are declaring a RACW in the same package than its designated
 535          --  type, so the list to use for late declarations must be the
 536          --  private part of the package. We do know that this private part
 537          --  exists since the designated type has to be a private one.
 538
 539          Decls := Private_Declarations
 540            (Package_Specification_Of_Scope (Current_Scope));
 541
 542       elsif Nkind (Parent (Decls)) = N_Package_Specification
 543         and then Present (Private_Declarations (Parent (Decls)))
 544       then
 545          Decls := Private_Declarations (Parent (Decls));
 546       end if;
 547
 548       --  If we were unable to find the declarations, that means that the
 549       --  completion of the type was missing. We can safely return and let
 550       --  the error be caught by the semantic analysis.
 551
 552       if No (Decls) then
 553          return;
 554       end if;
 555
 556       Add_Stub_Type
 557         (Designated_Type     => Desig,
 558          RACW_Type           => RACW_Type,
 559          Decls               => Decls,
 560          Stub_Type           => Stub_Type,
 561          Stub_Type_Access    => Stub_Type_Access,
 562          Object_RPC_Receiver => Object_RPC_Receiver,
 563          Existing            => Existing);
 564
 565       Add_RACW_Asynchronous_Flag
 566         (Declarations        => Decls,
 567          RACW_Type           => RACW_Type);
 568
 569       Add_RACW_Read_Write_Attributes
 570         (RACW_Type           => RACW_Type,
 571          Stub_Type           => Stub_Type,
 572          Stub_Type_Access    => Stub_Type_Access,
 573          Object_RPC_Receiver => Object_RPC_Receiver,
 574          Declarations        => Decls);
 575
 576       if not Same_Scope and then not Existing then
 577
 578          --  The RACW has been declared in another scope than the designated
 579          --  type and has not been handled by another RACW in the same package
 580          --  as the first one, so add primitive for the stub type here.
 581
 582          Add_RACW_Primitive_Declarations_And_Bodies
 583            (Designated_Type  => Desig,
 584             Insertion_Node   =>
 585               Parent (Declaration_Node (Object_RPC_Receiver)),
 586             Decls            => Decls);
 587
 588       else
 589          Add_Access_Type_To_Process (E => Desig, A => RACW_Type);
 590       end if;
 591    end Add_RACW_Features;
 592
 593    ------------------------------------------------
 594    -- Add_RACW_Primitive_Declarations_And_Bodies --
 595    ------------------------------------------------
 596
 597    procedure Add_RACW_Primitive_Declarations_And_Bodies
 598      (Designated_Type : Entity_Id;
 599       Insertion_Node  : Node_Id;
 600       Decls           : List_Id)
 601    is
 602       --  Set sloc of generated declaration copy of insertion node sloc, so
 603       --  the declarations are recognized as belonging to the current package.
 604
 605       Loc : constant Source_Ptr := Sloc (Insertion_Node);
 606
 607       Stub_Elements : constant Stub_Structure :=
 608                         Stubs_Table.Get (Designated_Type);
 609
 610       pragma Assert (Stub_Elements /= Empty_Stub_Structure);
 611
 612       Current_Insertion_Node : Node_Id := Insertion_Node;
 613
 614       RPC_Receiver_Declarations      : List_Id;
 615       RPC_Receiver_Statements        : List_Id;
 616       RPC_Receiver_Case_Alternatives : constant List_Id := New_List;
 617       RPC_Receiver_Subp_Id           : Entity_Id;
 618
 619       Current_Primitive_Elmt   : Elmt_Id;
 620       Current_Primitive        : Entity_Id;
 621       Current_Primitive_Body   : Node_Id;
 622       Current_Primitive_Spec   : Node_Id;
 623       Current_Primitive_Decl   : Node_Id;
 624       Current_Primitive_Number : Int := 0;
 625
 626       Current_Primitive_Alias : Node_Id;
 627
 628       Current_Receiver      : Entity_Id;
 629       Current_Receiver_Body : Node_Id;
 630
 631       RPC_Receiver_Decl : Node_Id;
 632
 633       Possibly_Asynchronous : Boolean;
 634
 635    begin
 636       if not Expander_Active then
 637          return;
 638       end if;
 639
 640       --  Build callers, receivers for every primitive operations and a RPC
 641       --  receiver for this type.
 642
 643       if Present (Primitive_Operations (Designated_Type)) then
 644
 645          Current_Primitive_Elmt :=
 646            First_Elmt (Primitive_Operations (Designated_Type));
 647          while Current_Primitive_Elmt /= No_Elmt loop
 648             Current_Primitive := Node (Current_Primitive_Elmt);
 649
 650             --  Copy the primitive of all the parents, except predefined
 651             --  ones that are not remotely dispatching.
 652
 653             if Chars (Current_Primitive) /= Name_uSize
 654               and then Chars (Current_Primitive) /= Name_uAlignment
 655               and then not Is_TSS (Current_Primitive, TSS_Deep_Finalize)
 656             then
 657                --  The first thing to do is build an up-to-date copy of
 658                --  the spec with all the formals referencing Designated_Type
 659                --  transformed into formals referencing Stub_Type. Since this
 660                --  primitive may have been inherited, go back the alias chain
 661                --  until the real primitive has been found.
 662
 663                Current_Primitive_Alias := Current_Primitive;
 664                while Present (Alias (Current_Primitive_Alias)) loop
 665                   pragma Assert
 666                     (Current_Primitive_Alias
 667                       /= Alias (Current_Primitive_Alias));
 668                   Current_Primitive_Alias := Alias (Current_Primitive_Alias);
 669                end loop;
 670
 671                Current_Primitive_Spec :=
 672                  Copy_Specification (Loc,
 673                    Spec        => Parent (Current_Primitive_Alias),
 674                    Object_Type => Designated_Type,
 675                    Stub_Type   => Stub_Elements.Stub_Type);
 676
 677                Current_Primitive_Decl :=
 678                  Make_Subprogram_Declaration (Loc,
 679                    Specification => Current_Primitive_Spec);
 680
 681                Insert_After (Current_Insertion_Node, Current_Primitive_Decl);
 682                Analyze (Current_Primitive_Decl);
 683                Current_Insertion_Node := Current_Primitive_Decl;
 684
 685                Possibly_Asynchronous :=
 686                  Nkind (Current_Primitive_Spec) = N_Procedure_Specification
 687                  and then Could_Be_Asynchronous (Current_Primitive_Spec);
 688
 689                Current_Primitive_Body :=
 690                  Build_Subprogram_Calling_Stubs
 691                    (Vis_Decl                 => Current_Primitive_Decl,
 692                     Subp_Id                  => Current_Primitive_Number,
 693                     Asynchronous             => Possibly_Asynchronous,
 694                     Dynamically_Asynchronous => Possibly_Asynchronous,
 695                     Stub_Type                => Stub_Elements.Stub_Type);
 696                Append_To (Decls, Current_Primitive_Body);
 697
 698                --  Analyzing the body here would cause the Stub type to be
 699                --  frozen, thus preventing subsequent primitive declarations.
 700                --  For this reason, it will be analyzed later in the
 701                --  regular flow.
 702
 703                --  Build the receiver stubs
 704
 705                Current_Receiver_Body :=
 706                  Build_Subprogram_Receiving_Stubs
 707                    (Vis_Decl                 => Current_Primitive_Decl,
 708                     Asynchronous             => Possibly_Asynchronous,
 709                     Dynamically_Asynchronous => Possibly_Asynchronous,
 710                     Stub_Type                => Stub_Elements.Stub_Type,
 711                     RACW_Type                => Stub_Elements.RACW_Type,
 712                     Parent_Primitive         => Current_Primitive);
 713
 714                Current_Receiver :=
 715                   Defining_Unit_Name (Specification (Current_Receiver_Body));
 716
 717                Append_To (Decls, Current_Receiver_Body);
 718
 719                --  Add a case alternative to the receiver
 720
 721                Append_To (RPC_Receiver_Case_Alternatives,
 722                  Make_Case_Statement_Alternative (Loc,
 723                    Discrete_Choices => New_List (
 724                      Make_Integer_Literal (Loc, Current_Primitive_Number)),
 725
 726                    Statements       => New_List (
 727                      Make_Procedure_Call_Statement (Loc,
 728                        Name                   =>
 729                          New_Occurrence_Of (Current_Receiver, Loc),
 730                        Parameter_Associations => New_List (
 731                          New_Occurrence_Of
 732                            (Stub_Elements.RPC_Receiver_Stream, Loc),
 733                          New_Occurrence_Of
 734                            (Stub_Elements.RPC_Receiver_Result, Loc))))));
 735
 736                --  Increment the index of current primitive
 737
 738                Current_Primitive_Number := Current_Primitive_Number + 1;
 739             end if;
 740
 741             Next_Elmt (Current_Primitive_Elmt);
 742          end loop;
 743       end if;
 744
 745       --  Build the case statement and the heart of the subprogram
 746
 747       Append_To (RPC_Receiver_Case_Alternatives,
 748         Make_Case_Statement_Alternative (Loc,
 749           Discrete_Choices => New_List (Make_Others_Choice (Loc)),
 750           Statements       => New_List (Make_Null_Statement (Loc))));
 751
 752       RPC_Receiver_Subp_Id :=
 753         Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
 754
 755       RPC_Receiver_Declarations := New_List (
 756         Make_Object_Declaration (Loc,
 757           Defining_Identifier => RPC_Receiver_Subp_Id,
 758           Object_Definition   =>
 759             New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc)));
 760
 761       RPC_Receiver_Statements := New_List (
 762         Make_Attribute_Reference (Loc,
 763           Prefix         =>
 764             New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
 765           Attribute_Name =>
 766             Name_Read,
 767           Expressions    => New_List (
 768             New_Occurrence_Of (Stub_Elements.RPC_Receiver_Stream, Loc),
 769             New_Occurrence_Of (RPC_Receiver_Subp_Id, Loc))));
 770
 771       Append_To (RPC_Receiver_Statements,
 772         Make_Case_Statement (Loc,
 773           Expression   =>
 774             New_Occurrence_Of (RPC_Receiver_Subp_Id, Loc),
 775           Alternatives => RPC_Receiver_Case_Alternatives));
 776
 777       RPC_Receiver_Decl :=
 778         Make_Subprogram_Body (Loc,
 779           Specification              =>
 780             Copy_Specification (Loc,
 781               Parent (Stub_Elements.Object_RPC_Receiver)),
 782           Declarations               => RPC_Receiver_Declarations,
 783           Handled_Statement_Sequence =>
 784             Make_Handled_Sequence_Of_Statements (Loc,
 785               Statements => RPC_Receiver_Statements));
 786
 787       Append_To (Decls, RPC_Receiver_Decl);
 788
 789       --  Do not analyze RPC receiver at this stage since it will otherwise
 790       --  reference subprograms that have not been analyzed yet. It will
 791       --  be analyzed in the regular flow.
 792
 793    end Add_RACW_Primitive_Declarations_And_Bodies;
 794
 795    -----------------------------
 796    -- Add_RACW_Read_Attribute --
 797    -----------------------------
 798
 799    procedure Add_RACW_Read_Attribute
 800      (RACW_Type           : Entity_Id;
 801       Stub_Type           : Entity_Id;
 802       Stub_Type_Access    : Entity_Id;
 803       Declarations        : List_Id)
 804    is
 805       Loc : constant Source_Ptr := Sloc (RACW_Type);
 806
 807       Proc_Decl : Node_Id;
 808       Attr_Decl : Node_Id;
 809
 810       Body_Node : Node_Id;
 811
 812       Decls             : List_Id;
 813       Statements        : List_Id;
 814       Local_Statements  : List_Id;
 815       Remote_Statements : List_Id;
 816       --  Various parts of the procedure
 817
 818       Procedure_Name    : constant Name_Id   :=
 819                             New_Internal_Name ('R');
 820       Source_Partition  : constant Entity_Id :=
 821                             Make_Defining_Identifier
 822                               (Loc, New_Internal_Name ('P'));
 823       Source_Receiver   : constant Entity_Id :=
 824                             Make_Defining_Identifier
 825                               (Loc, New_Internal_Name ('S'));
 826       Source_Address    : constant Entity_Id :=
 827                             Make_Defining_Identifier
 828                               (Loc, New_Internal_Name ('P'));
 829       Local_Stub        : constant Entity_Id :=
 830                             Make_Defining_Identifier
 831                               (Loc, New_Internal_Name ('L'));
 832       Stubbed_Result    : constant Entity_Id :=
 833                             Make_Defining_Identifier
 834                               (Loc, New_Internal_Name ('S'));
 835       Asynchronous_Flag : constant Entity_Id :=
 836                             Asynchronous_Flags_Table.Get (RACW_Type);
 837       pragma Assert (Present (Asynchronous_Flag));
 838
 839       function Stream_Parameter return Node_Id;
 840       function Result return Node_Id;
 841       --  Functions to create occurrences of the formal parameter names
 842
 843       ------------
 844       -- Result --
 845       ------------
 846
 847       function Result return Node_Id is
 848       begin
 849          return Make_Identifier (Loc, Name_V);
 850       end Result;
 851
 852       ----------------------
 853       -- Stream_Parameter --
 854       ----------------------
 855
 856       function Stream_Parameter return Node_Id is
 857       begin
 858          return Make_Identifier (Loc, Name_S);
 859       end Stream_Parameter;
 860
 861    --  Start of processing for Add_RACW_Read_Attribute
 862
 863    begin
 864       --  Generate object declarations
 865
 866       Decls := New_List (
 867         Make_Object_Declaration (Loc,
 868           Defining_Identifier => Source_Partition,
 869           Object_Definition   =>
 870             New_Occurrence_Of (RTE (RE_Partition_ID), Loc)),
 871
 872         Make_Object_Declaration (Loc,
 873           Defining_Identifier => Source_Receiver,
 874           Object_Definition   =>
 875             New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
 876
 877         Make_Object_Declaration (Loc,
 878           Defining_Identifier => Source_Address,
 879           Object_Definition   =>
 880             New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
 881
 882         Make_Object_Declaration (Loc,
 883           Defining_Identifier => Local_Stub,
 884           Aliased_Present     => True,
 885           Object_Definition   => New_Occurrence_Of (Stub_Type, Loc)),
 886
 887         Make_Object_Declaration (Loc,
 888           Defining_Identifier => Stubbed_Result,
 889           Object_Definition   =>
 890             New_Occurrence_Of (Stub_Type_Access, Loc),
 891           Expression          =>
 892             Make_Attribute_Reference (Loc,
 893               Prefix =>
 894                 New_Occurrence_Of (Local_Stub, Loc),
 895               Attribute_Name =>
 896                 Name_Unchecked_Access)));
 897
 898       --  Read the source Partition_ID and RPC_Receiver from incoming stream
 899
 900       Statements := New_List (
 901         Make_Attribute_Reference (Loc,
 902           Prefix         =>
 903             New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
 904           Attribute_Name => Name_Read,
 905           Expressions    => New_List (
 906             Stream_Parameter,
 907             New_Occurrence_Of (Source_Partition, Loc))),
 908
 909         Make_Attribute_Reference (Loc,
 910           Prefix         =>
 911             New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
 912           Attribute_Name =>
 913             Name_Read,
 914           Expressions    => New_List (
 915             Stream_Parameter,
 916             New_Occurrence_Of (Source_Receiver, Loc))),
 917
 918         Make_Attribute_Reference (Loc,
 919           Prefix         =>
 920             New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
 921           Attribute_Name =>
 922             Name_Read,
 923           Expressions    => New_List (
 924             Stream_Parameter,
 925             New_Occurrence_Of (Source_Address, Loc))));
 926
 927       --  Build_Get_Unique_RP_Call needs the type of Stubbed_Result
 928
 929       Set_Etype (Stubbed_Result, Stub_Type_Access);
 930
 931       --  If the Address is Null_Address, then return a null object
 932
 933       Append_To (Statements,
 934         Make_Implicit_If_Statement (RACW_Type,
 935           Condition       =>
 936             Make_Op_Eq (Loc,
 937               Left_Opnd  => New_Occurrence_Of (Source_Address, Loc),
 938               Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
 939           Then_Statements => New_List (
 940             Make_Assignment_Statement (Loc,
 941               Name       => Result,
 942               Expression => Make_Null (Loc)),
 943             Make_Return_Statement (Loc))));
 944
 945       --  If the RACW denotes an object created on the current partition, then
 946       --  Local_Statements will be executed. The real object will be used.
 947
 948       Local_Statements := New_List (
 949         Make_Assignment_Statement (Loc,
 950           Name       => Result,
 951           Expression =>
 952             Unchecked_Convert_To (RACW_Type,
 953               OK_Convert_To (RTE (RE_Address),
 954                 New_Occurrence_Of (Source_Address, Loc)))));
 955
 956       --  If the object is located on another partition, then a stub object
 957       --  will be created with all the information needed to rebuild the
 958       --  real object at the other end.
 959
 960       Remote_Statements := New_List (
 961
 962         Make_Assignment_Statement (Loc,
 963           Name       => Make_Selected_Component (Loc,
 964             Prefix        => New_Occurrence_Of (Stubbed_Result, Loc),
 965             Selector_Name => Make_Identifier (Loc, Name_Origin)),
 966           Expression =>
 967             New_Occurrence_Of (Source_Partition, Loc)),
 968
 969         Make_Assignment_Statement (Loc,
 970           Name       => Make_Selected_Component (Loc,
 971             Prefix        => New_Occurrence_Of (Stubbed_Result, Loc),
 972             Selector_Name => Make_Identifier (Loc, Name_Receiver)),
 973           Expression =>
 974             New_Occurrence_Of (Source_Receiver, Loc)),
 975
 976         Make_Assignment_Statement (Loc,
 977           Name       => Make_Selected_Component (Loc,
 978             Prefix        => New_Occurrence_Of (Stubbed_Result, Loc),
 979             Selector_Name => Make_Identifier (Loc, Name_Addr)),
 980           Expression =>
 981             New_Occurrence_Of (Source_Address, Loc)));
 982
 983       Append_To (Remote_Statements,
 984         Make_Assignment_Statement (Loc,
 985           Name       => Make_Selected_Component (Loc,
 986             Prefix        => New_Occurrence_Of (Stubbed_Result, Loc),
 987             Selector_Name => Make_Identifier (Loc, Name_Asynchronous)),
 988           Expression =>
 989             New_Occurrence_Of (Asynchronous_Flag, Loc)));
 990
 991       Append_List_To (Remote_Statements,
 992         Build_Get_Unique_RP_Call (Loc, Stubbed_Result, Stub_Type));
 993       --  ??? Issue with asynchronous calls here: the Asynchronous
 994       --  flag is set on the stub type if, and only if, the RACW type
 995       --  has a pragma Asynchronous. This is incorrect for RACWs that
 996       --  implement RAS types, because in that case the /designated
 997       --  subprogram/ (not the type) might be asynchronous, and
 998       --  that causes the stub to need to be asynchronous too.
 999       --  A solution is to transport a RAS as a struct containing
1000       --  a RACW and an asynchronous flag, and to properly alter
1001       --  the Asynchronous component in the stub type in the RAS's
1002       --  Input TSS.
1003
1004       Append_To (Remote_Statements,
1005         Make_Assignment_Statement (Loc,
1006           Name       => Result,
1007           Expression => Unchecked_Convert_To (RACW_Type,
1008             New_Occurrence_Of (Stubbed_Result, Loc))));
1009
1010       --  Distinguish between the local and remote cases, and execute the
1011       --  appropriate piece of code.
1012
1013       Append_To (Statements,
1014         Make_Implicit_If_Statement (RACW_Type,
1015           Condition       =>
1016             Make_Op_Eq (Loc,
1017               Left_Opnd  =>
1018                 Make_Function_Call (Loc,
1019                   Name =>
1020                     New_Occurrence_Of (RTE (RE_Get_Local_Partition_Id), Loc)),
1021               Right_Opnd => New_Occurrence_Of (Source_Partition, Loc)),
1022           Then_Statements => Local_Statements,
1023           Else_Statements => Remote_Statements));
1024
1025       Build_Stream_Procedure
1026         (Loc, RACW_Type, Body_Node,
1027          Make_Defining_Identifier (Loc, Procedure_Name),
1028          Statements, Outp => True);
1029       Set_Declarations (Body_Node, Decls);
1030
1031       Proc_Decl := Make_Subprogram_Declaration (Loc,
1032         Copy_Specification (Loc, Specification (Body_Node)));
1033
1034       Attr_Decl :=
1035         Make_Attribute_Definition_Clause (Loc,
1036           Name       => New_Occurrence_Of (RACW_Type, Loc),
1037           Chars      => Name_Read,
1038           Expression =>
1039             New_Occurrence_Of (
1040               Defining_Unit_Name (Specification (Proc_Decl)), Loc));
1041
1042       Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
1043       Insert_After (Proc_Decl, Attr_Decl);
1044       Append_To (Declarations, Body_Node);
1045    end Add_RACW_Read_Attribute;
1046
1047    ------------------------------------
1048    -- Add_RACW_Read_Write_Attributes --
1049    ------------------------------------
1050
1051    procedure Add_RACW_Read_Write_Attributes
1052      (RACW_Type           : Entity_Id;
1053       Stub_Type           : Entity_Id;
1054       Stub_Type_Access    : Entity_Id;
1055       Object_RPC_Receiver : Entity_Id;
1056       Declarations        : List_Id)
1057    is
1058    begin
1059       Add_RACW_Write_Attribute
1060         (RACW_Type           => RACW_Type,
1061          Stub_Type           => Stub_Type,
1062          Stub_Type_Access    => Stub_Type_Access,
1063          Object_RPC_Receiver => Object_RPC_Receiver,
1064          Declarations        => Declarations);
1065
1066       Add_RACW_Read_Attribute
1067         (RACW_Type        => RACW_Type,
1068          Stub_Type        => Stub_Type,
1069          Stub_Type_Access => Stub_Type_Access,
1070          Declarations     => Declarations);
1071    end Add_RACW_Read_Write_Attributes;
1072
1073    ------------------------------
1074    -- Add_RACW_Write_Attribute --
1075    ------------------------------
1076
1077    procedure Add_RACW_Write_Attribute
1078      (RACW_Type           : Entity_Id;
1079       Stub_Type           : Entity_Id;
1080       Stub_Type_Access    : Entity_Id;
1081       Object_RPC_Receiver : Entity_Id;
1082       Declarations        : List_Id)
1083    is
1084       Loc : constant Source_Ptr := Sloc (RACW_Type);
1085
1086       Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
1087
1088       Body_Node : Node_Id;
1089       Proc_Decl : Node_Id;
1090       Attr_Decl : Node_Id;
1091
1092       RPC_Receiver : Node_Id;
1093
1094       Statements        : List_Id;
1095       Local_Statements  : List_Id;
1096       Remote_Statements : List_Id;
1097       Null_Statements   : List_Id;
1098
1099       Procedure_Name    : constant Name_Id := New_Internal_Name ('R');
1100
1101       --  Functions to create occurrences of the formal
1102       --  parameter names.
1103
1104       function Stream_Parameter return Node_Id;
1105       function Object return Node_Id;
1106
1107       function Stream_Parameter return Node_Id is
1108       begin
1109          return Make_Identifier (Loc, Name_S);
1110       end Stream_Parameter;
1111
1112       function Object return Node_Id is
1113       begin
1114          return Make_Identifier (Loc, Name_V);
1115       end Object;
1116
1117    begin
1118       --  Build the code fragment corresponding to the marshalling of a
1119       --  local object.
1120
1121       if Is_RAS then
1122
1123          --  For a RAS, the RPC receiver is that of the RCI unit,
1124          --  not that of the corresponding distributed object type.
1125          --  We retrieve its address from the local proxy object.
1126
1127          RPC_Receiver := Make_Selected_Component (Loc,
1128            Prefix         =>
1129              Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access), Object),
1130            Selector_Name =>
1131              Make_Identifier (Loc, Name_Receiver));
1132
1133       else
1134          RPC_Receiver := Make_Attribute_Reference (Loc,
1135            Prefix         =>
1136              New_Occurrence_Of (Object_RPC_Receiver, Loc),
1137            Attribute_Name =>
1138              Name_Address);
1139       end if;
1140
1141       Local_Statements := New_List (
1142
1143         Pack_Entity_Into_Stream_Access (Loc,
1144           Stream => Stream_Parameter,
1145           Object => RTE (RE_Get_Local_Partition_Id)),
1146
1147         Pack_Node_Into_Stream_Access (Loc,
1148           Stream => Stream_Parameter,
1149           Object => OK_Convert_To (RTE (RE_Unsigned_64), RPC_Receiver),
1150           Etyp   => RTE (RE_Unsigned_64)),
1151
1152        Pack_Node_Into_Stream_Access (Loc,
1153          Stream => Stream_Parameter,
1154          Object => OK_Convert_To (RTE (RE_Unsigned_64),
1155            Make_Attribute_Reference (Loc,
1156              Prefix         =>
1157                Make_Explicit_Dereference (Loc,
1158                  Prefix => Object),
1159              Attribute_Name => Name_Address)),
1160          Etyp   => RTE (RE_Unsigned_64)));
1161
1162       --  Build the code fragment corresponding to the marshalling of
1163       --  a remote object.
1164
1165       Remote_Statements := New_List (
1166
1167         Pack_Node_Into_Stream_Access (Loc,
1168          Stream => Stream_Parameter,
1169          Object =>
1170             Make_Selected_Component (Loc,
1171               Prefix        => Unchecked_Convert_To (Stub_Type_Access,
1172                 Object),
1173               Selector_Name =>
1174                 Make_Identifier (Loc, Name_Origin)),
1175          Etyp   => RTE (RE_Partition_ID)),
1176
1177         Pack_Node_Into_Stream_Access (Loc,
1178          Stream => Stream_Parameter,
1179          Object =>
1180             Make_Selected_Component (Loc,
1181               Prefix        => Unchecked_Convert_To (Stub_Type_Access,
1182                 Object),
1183               Selector_Name =>
1184                 Make_Identifier (Loc, Name_Receiver)),
1185          Etyp   => RTE (RE_Unsigned_64)),
1186
1187         Pack_Node_Into_Stream_Access (Loc,
1188          Stream => Stream_Parameter,
1189          Object =>
1190             Make_Selected_Component (Loc,
1191               Prefix        => Unchecked_Convert_To (Stub_Type_Access,
1192                 Object),
1193               Selector_Name =>
1194                 Make_Identifier (Loc, Name_Addr)),
1195          Etyp   => RTE (RE_Unsigned_64)));
1196
1197       --  Build the code fragment corresponding to the marshalling of a null
1198       --  object.
1199
1200       Null_Statements := New_List (
1201
1202         Pack_Entity_Into_Stream_Access (Loc,
1203           Stream => Stream_Parameter,
1204           Object => RTE (RE_Get_Local_Partition_Id)),
1205
1206         Pack_Node_Into_Stream_Access (Loc,
1207           Stream => Stream_Parameter,
1208           Object => OK_Convert_To (RTE (RE_Unsigned_64),
1209             Make_Attribute_Reference (Loc,
1210               Prefix         => New_Occurrence_Of (Object_RPC_Receiver, Loc),
1211               Attribute_Name => Name_Address)),
1212           Etyp   => RTE (RE_Unsigned_64)),
1213
1214         Pack_Node_Into_Stream_Access (Loc,
1215           Stream => Stream_Parameter,
1216           Object => Make_Integer_Literal (Loc, Uint_0),
1217           Etyp   => RTE (RE_Unsigned_64)));
1218
1219       Statements := New_List (
1220         Make_Implicit_If_Statement (RACW_Type,
1221           Condition       =>
1222             Make_Op_Eq (Loc,
1223               Left_Opnd  => Object,
1224               Right_Opnd => Make_Null (Loc)),
1225           Then_Statements => Null_Statements,
1226           Elsif_Parts     => New_List (
1227             Make_Elsif_Part (Loc,
1228               Condition       =>
1229                 Make_Op_Eq (Loc,
1230                   Left_Opnd  =>
1231                     Make_Attribute_Reference (Loc,
1232                       Prefix         => Object,
1233                       Attribute_Name => Name_Tag),
1234                   Right_Opnd =>
1235                     Make_Attribute_Reference (Loc,
1236                       Prefix         => New_Occurrence_Of (Stub_Type, Loc),
1237                       Attribute_Name => Name_Tag)),
1238               Then_Statements => Remote_Statements)),
1239           Else_Statements => Local_Statements));
1240
1241       Build_Stream_Procedure
1242         (Loc, RACW_Type, Body_Node,
1243          Make_Defining_Identifier (Loc, Procedure_Name),
1244          Statements, Outp => False);
1245
1246       Proc_Decl := Make_Subprogram_Declaration (Loc,
1247         Copy_Specification (Loc, Specification (Body_Node)));
1248
1249       Attr_Decl :=
1250         Make_Attribute_Definition_Clause (Loc,
1251           Name       => New_Occurrence_Of (RACW_Type, Loc),
1252           Chars      => Name_Write,
1253           Expression =>
1254             New_Occurrence_Of (
1255               Defining_Unit_Name (Specification (Proc_Decl)), Loc));
1256
1257       Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
1258       Insert_After (Proc_Decl, Attr_Decl);
1259       Append_To (Declarations, Body_Node);
1260    end Add_RACW_Write_Attribute;
1261
1262    ------------------------
1263    -- Add_RAS_Access_TSS --
1264    ------------------------
1265
1266    procedure Add_RAS_Access_TSS (N : Node_Id) is
1267       Loc : constant Source_Ptr := Sloc (N);
1268
1269       Ras_Type : constant Entity_Id := Defining_Identifier (N);
1270       Fat_Type : constant Entity_Id := Equivalent_Type (Ras_Type);
1271       --  Ras_Type is the access to subprogram type while Fat_Type points to
1272       --  the record type corresponding to a remote access to subprogram type.
1273
1274       RACW_Type : constant Entity_Id :=
1275         Underlying_RACW_Type (Ras_Type);
1276       Desig     : constant Entity_Id :=
1277         Etype (Designated_Type (RACW_Type));
1278
1279       Stub_Elements : constant Stub_Structure :=
1280         Stubs_Table.Get (Desig);
1281       pragma Assert (Stub_Elements /= Empty_Stub_Structure);
1282
1283       Proc : constant Entity_Id :=
1284                Make_Defining_Identifier (Loc,
1285                  Chars => Make_TSS_Name (Ras_Type, TSS_RAS_Access));
1286       Proc_Spec : Node_Id;
1287
1288       --  Formal parameters
1289
1290       Package_Name : constant Entity_Id :=
1291                        Make_Defining_Identifier (Loc,
1292                          Chars => Name_P);
1293       --  Target package
1294
1295       Subp_Id : constant Entity_Id :=
1296                   Make_Defining_Identifier (Loc,
1297                     Chars => Name_S);
1298       --  Target subprogram
1299
1300       Asynch_P : constant Entity_Id :=
1301                    Make_Defining_Identifier (Loc,
1302                      Chars => Name_Asynchronous);
1303       --  Is the procedure to which the 'Access applies asynchronous?
1304
1305       All_Calls_Remote : constant Entity_Id :=
1306                            Make_Defining_Identifier (Loc,
1307                              Chars => Name_All_Calls_Remote);
1308       --  True if an All_Calls_Remote pragma applies to the RCI unit
1309       --  that contains the subprogram.
1310
1311       --  Common local variables
1312
1313       Proc_Decls        : List_Id;
1314       Proc_Statements   : List_Id;
1315
1316       Origin : constant Entity_Id :=
1317                  Make_Defining_Identifier (Loc,
1318                    Chars => New_Internal_Name ('P'));
1319
1320       --  Additional local variables for the local case
1321
1322       Proxy_Addr : constant Entity_Id :=
1323                      Make_Defining_Identifier (Loc,
1324                        Chars => New_Internal_Name ('P'));
1325
1326       --  Additional local variables for the remote case
1327
1328       Local_Stub : constant Entity_Id :=
1329                      Make_Defining_Identifier (Loc,
1330                        Chars => New_Internal_Name ('L'));
1331
1332       Stub_Ptr : constant Entity_Id :=
1333                    Make_Defining_Identifier (Loc,
1334                      Chars => New_Internal_Name ('S'));
1335
1336       function Set_Field
1337         (Field_Name : Name_Id;
1338          Value      : Node_Id) return Node_Id;
1339       --  Construct an assignment that sets the named component in the
1340       --  returned record
1341
1342       ---------------
1343       -- Set_Field --
1344       ---------------
1345
1346       function Set_Field
1347         (Field_Name : Name_Id;
1348          Value      : Node_Id) return Node_Id
1349       is
1350       begin
1351          return
1352            Make_Assignment_Statement (Loc,
1353              Name       =>
1354                Make_Selected_Component (Loc,
1355                  Prefix        => New_Occurrence_Of (Stub_Ptr, Loc),
1356                  Selector_Name => Make_Identifier (Loc, Field_Name)),
1357              Expression => Value);
1358       end Set_Field;
1359
1360    --  Start of processing for Add_RAS_Access_TSS
1361
1362    begin
1363       Proc_Decls := New_List (
1364
1365       --  Common declarations
1366
1367         Make_Object_Declaration (Loc,
1368           Defining_Identifier => Origin,
1369           Constant_Present    => True,
1370           Object_Definition   =>
1371             New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
1372           Expression          =>
1373             Make_Function_Call (Loc,
1374               Name                   =>
1375                 New_Occurrence_Of (RTE (RE_Get_Active_Partition_Id), Loc),
1376               Parameter_Associations => New_List (
1377                 New_Occurrence_Of (Package_Name, Loc)))),
1378
1379       --  Declaration use only in the local case: proxy address
1380
1381         Make_Object_Declaration (Loc,
1382           Defining_Identifier => Proxy_Addr,
1383           Object_Definition   =>
1384             New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
1385
1386       --  Declarations used only in the remote case: stub object and
1387       --  stub pointer.
1388
1389         Make_Object_Declaration (Loc,
1390           Defining_Identifier => Local_Stub,
1391           Aliased_Present     => True,
1392           Object_Definition   =>
1393             New_Occurrence_Of (Stub_Elements.Stub_Type, Loc)),
1394
1395         Make_Object_Declaration (Loc,
1396           Defining_Identifier =>
1397             Stub_Ptr,
1398           Object_Definition   =>
1399             New_Occurrence_Of (Stub_Elements.Stub_Type_Access, Loc),
1400           Expression          =>
1401             Make_Attribute_Reference (Loc,
1402               Prefix => New_Occurrence_Of (Local_Stub, Loc),
1403               Attribute_Name => Name_Unchecked_Access)));
1404
1405       Set_Etype (Stub_Ptr, Stub_Elements.Stub_Type_Access);
1406       --  Build_Get_Unique_RP_Call needs this information
1407
1408       --  Note: Here we assume that the Fat_Type is a record
1409       --  containing just a pointer to a proxy or stub object.
1410
1411       Proc_Statements := New_List (
1412
1413       --  Generate:
1414
1415       --    Get_RAS_Info (Pkg, Subp, PA);
1416       --    if Origin = Local_Partition_Id and then not All_Calls_Remote then
1417       --       return Fat_Type!(PA);
1418       --    end if;
1419
1420          Make_Procedure_Call_Statement (Loc,
1421            Name =>
1422              New_Occurrence_Of (RTE (RE_Get_RAS_Info), Loc),
1423            Parameter_Associations => New_List (
1424              New_Occurrence_Of (Package_Name, Loc),
1425              New_Occurrence_Of (Subp_Id, Loc),
1426              New_Occurrence_Of (Proxy_Addr, Loc))),
1427
1428         Make_Implicit_If_Statement (N,
1429           Condition =>
1430             Make_And_Then (Loc,
1431               Left_Opnd  =>
1432                 Make_Op_Eq (Loc,
1433                   Left_Opnd =>
1434                     New_Occurrence_Of (Origin, Loc),
1435                   Right_Opnd =>
1436                     Make_Function_Call (Loc,
1437                       New_Occurrence_Of (
1438                         RTE (RE_Get_Local_Partition_Id), Loc))),
1439               Right_Opnd =>
1440                 Make_Op_Not (Loc,
1441                   New_Occurrence_Of (All_Calls_Remote, Loc))),
1442           Then_Statements => New_List (
1443             Make_Return_Statement (Loc,
1444               Unchecked_Convert_To (Fat_Type,
1445                 OK_Convert_To (RTE (RE_Address),
1446                   New_Occurrence_Of (Proxy_Addr, Loc)))))),
1447
1448         Set_Field (Name_Origin,
1449             New_Occurrence_Of (Origin, Loc)),
1450
1451         Set_Field (Name_Receiver,
1452           Make_Function_Call (Loc,
1453             Name                   =>
1454               New_Occurrence_Of (RTE (RE_Get_RCI_Package_Receiver), Loc),
1455             Parameter_Associations => New_List (
1456               New_Occurrence_Of (Package_Name, Loc)))),
1457
1458         Set_Field (Name_Addr, New_Occurrence_Of (Proxy_Addr, Loc)),
1459
1460       --  E.4.1(9) A remote call is asynchronous if it is a call to
1461       --  a procedure, or a call through a value of an access-to-procedure
1462       --  type, to which a pragma Asynchronous applies.
1463
1464       --    Parameter Asynch_P is true when the procedure is asynchronous;
1465       --    Expression Asynch_T is true when the type is asynchronous.
1466
1467         Set_Field (Name_Asynchronous,
1468           Make_Or_Else (Loc,
1469             New_Occurrence_Of (Asynch_P, Loc),
1470             New_Occurrence_Of (Boolean_Literals (
1471               Is_Asynchronous (Ras_Type)), Loc))));
1472
1473       Append_List_To (Proc_Statements,
1474         Build_Get_Unique_RP_Call
1475           (Loc, Stub_Ptr, Stub_Elements.Stub_Type));
1476
1477       --  Return the newly created value
1478
1479       Append_To (Proc_Statements,
1480         Make_Return_Statement (Loc,
1481           Expression =>
1482             Unchecked_Convert_To (Fat_Type,
1483               New_Occurrence_Of (Stub_Ptr, Loc))));
1484
1485       Proc_Spec :=
1486         Make_Function_Specification (Loc,
1487           Defining_Unit_Name       => Proc,
1488           Parameter_Specifications => New_List (
1489             Make_Parameter_Specification (Loc,
1490               Defining_Identifier => Package_Name,
1491               Parameter_Type      =>
1492                 New_Occurrence_Of (Standard_String, Loc)),
1493
1494             Make_Parameter_Specification (Loc,
1495               Defining_Identifier => Subp_Id,
1496               Parameter_Type      =>
1497                 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc)),
1498
1499             Make_Parameter_Specification (Loc,
1500               Defining_Identifier => Asynch_P,
1501               Parameter_Type      =>
1502                 New_Occurrence_Of (Standard_Boolean, Loc)),
1503
1504             Make_Parameter_Specification (Loc,
1505               Defining_Identifier => All_Calls_Remote,
1506               Parameter_Type      =>
1507                 New_Occurrence_Of (Standard_Boolean, Loc))),
1508
1509          Subtype_Mark =>
1510            New_Occurrence_Of (Fat_Type, Loc));
1511
1512       --  Set the kind and return type of the function to prevent ambiguities
1513       --  between Ras_Type and Fat_Type in subsequent analysis.
1514
1515       Set_Ekind (Proc, E_Function);
1516       Set_Etype (Proc, New_Occurrence_Of (Fat_Type, Loc));
1517
1518       Discard_Node (
1519         Make_Subprogram_Body (Loc,
1520           Specification              => Proc_Spec,
1521           Declarations               => Proc_Decls,
1522           Handled_Statement_Sequence =>
1523             Make_Handled_Sequence_Of_Statements (Loc,
1524               Statements => Proc_Statements)));
1525
1526       Set_TSS (Fat_Type, Proc);
1527    end Add_RAS_Access_TSS;
1528
1529    -----------------------------
1530    -- Add_RAS_Dereference_TSS --
1531    -----------------------------
1532
1533    --  This subprogram could use more comments ???
1534
1535    procedure Add_RAS_Dereference_TSS (N : Node_Id) is
1536       Loc : constant Source_Ptr := Sloc (N);
1537
1538       Type_Def : constant Node_Id   := Type_Definition (N);
1539
1540       RAS_Type  : constant Entity_Id := Defining_Identifier (N);
1541       Fat_Type  : constant Entity_Id := Equivalent_Type (RAS_Type);
1542       RACW_Type : constant Entity_Id := Underlying_RACW_Type (RAS_Type);
1543       Desig     : constant Entity_Id := Etype (Designated_Type (RACW_Type));
1544
1545       Stub_Elements : constant Stub_Structure := Stubs_Table.Get (Desig);
1546       pragma Assert (Stub_Elements /= Empty_Stub_Structure);
1547
1548       RACW_Primitive_Name : Node_Id;
1549
1550       Proc : constant Entity_Id :=
1551                Make_Defining_Identifier (Loc,
1552                  Chars => Make_TSS_Name (RAS_Type, TSS_RAS_Dereference));
1553
1554       Proc_Spec   : Node_Id;
1555       Param_Specs : List_Id;
1556       Param_Assoc : constant List_Id := New_List;
1557       Stmts       : constant List_Id := New_List;
1558
1559       RAS_Parameter : constant Entity_Id :=
1560                         Make_Defining_Identifier (Loc,
1561                           Chars => New_Internal_Name ('P'));
1562
1563       Is_Function : constant Boolean :=
1564                       Nkind (Type_Def) = N_Access_Function_Definition;
1565
1566       Is_Degenerate : Boolean;
1567       --  Set to True if the subprogram_specification for this RAS has
1568       --  an anonymous access parameter (see Process_Remote_AST_Declaration).
1569
1570       Spec : constant Node_Id := Type_Def;
1571
1572       Current_Parameter : Node_Id;
1573
1574    begin
1575       Param_Specs := New_List (
1576         Make_Parameter_Specification (Loc,
1577           Defining_Identifier => RAS_Parameter,
1578           In_Present          => True,
1579           Parameter_Type      =>
1580             New_Occurrence_Of (Fat_Type, Loc)));
1581
1582       Is_Degenerate := False;
1583       Current_Parameter := First (Parameter_Specifications (Type_Def));
1584       Parameters : while Current_Parameter /= Empty loop
1585          if Nkind (Parameter_Type (Current_Parameter))
1586            = N_Access_Definition
1587          then
1588             Is_Degenerate := True;
1589          end if;
1590          Append_To (Param_Specs,
1591            Make_Parameter_Specification (Loc,
1592              Defining_Identifier =>
1593                Make_Defining_Identifier (Loc,
1594                  Chars => Chars (Defining_Identifier (Current_Parameter))),
1595              In_Present        => In_Present (Current_Parameter),
1596              Out_Present       => Out_Present (Current_Parameter),
1597              Parameter_Type    =>
1598                New_Copy_Tree (Parameter_Type (Current_Parameter)),
1599              Expression        =>
1600                New_Copy_Tree (Expression (Current_Parameter))));
1601
1602          Append_To (Param_Assoc,
1603            Make_Identifier (Loc,
1604              Chars => Chars (Defining_Identifier (Current_Parameter))));
1605
1606          Next (Current_Parameter);
1607       end loop Parameters;
1608
1609       if Is_Degenerate then
1610          Prepend_To (Param_Assoc, New_Occurrence_Of (RAS_Parameter, Loc));
1611
1612          --  Generate a dummy body recursing on the Dereference TSS, since
1613          --  actually it will never be executed.
1614
1615          Append_To (Stmts,
1616            Make_Raise_Program_Error (Loc, Reason => PE_Explicit_Raise));
1617          RACW_Primitive_Name := New_Occurrence_Of (Proc, Loc);
1618
1619       else
1620          Prepend_To (Param_Assoc,
1621            Unchecked_Convert_To (RACW_Type,
1622              New_Occurrence_Of (RAS_Parameter, Loc)));
1623
1624          RACW_Primitive_Name :=
1625            Make_Selected_Component (Loc,
1626              Prefix =>
1627                New_Occurrence_Of (Scope (RACW_Type), Loc),
1628              Selector_Name =>
1629                Make_Identifier (Loc, Name_Call));
1630       end if;
1631
1632       if Is_Function then
1633          Append_To (Stmts,
1634             Make_Return_Statement (Loc,
1635               Expression =>
1636                 Make_Function_Call (Loc,
1637               Name                   =>
1638                 RACW_Primitive_Name,
1639               Parameter_Associations => Param_Assoc)));
1640
1641       else
1642          Append_To (Stmts,
1643            Make_Procedure_Call_Statement (Loc,
1644              Name                   =>
1645                RACW_Primitive_Name,
1646              Parameter_Associations => Param_Assoc));
1647       end if;
1648
1649       --  Build the complete subprogram
1650
1651       if Is_Function then
1652          Proc_Spec :=
1653            Make_Function_Specification (Loc,
1654              Defining_Unit_Name       => Proc,
1655              Parameter_Specifications => Param_Specs,
1656              Subtype_Mark             =>
1657                New_Occurrence_Of (
1658                  Entity (Subtype_Mark (Spec)), Loc));
1659
1660          Set_Ekind (Proc, E_Function);
1661          Set_Etype (Proc,
1662            New_Occurrence_Of (Entity (Subtype_Mark (Spec)), Loc));
1663
1664       else
1665          Proc_Spec :=
1666            Make_Procedure_Specification (Loc,
1667              Defining_Unit_Name       => Proc,
1668              Parameter_Specifications => Param_Specs);
1669
1670          Set_Ekind (Proc, E_Procedure);
1671          Set_Etype (Proc, Standard_Void_Type);
1672       end if;
1673
1674       Discard_Node (
1675         Make_Subprogram_Body (Loc,
1676           Specification              => Proc_Spec,
1677           Declarations               => New_List,
1678           Handled_Statement_Sequence =>
1679             Make_Handled_Sequence_Of_Statements (Loc,
1680               Statements => Stmts)));
1681
1682       Set_TSS (Fat_Type, Proc);
1683    end Add_RAS_Dereference_TSS;
1684
1685    -------------------------------
1686    -- Add_RAS_Proxy_And_Analyze --
1687    -------------------------------
1688
1689    procedure Add_RAS_Proxy_And_Analyze
1690      (Decls              :     List_Id;
1691       Vis_Decl           :     Node_Id;
1692       All_Calls_Remote_E :     Entity_Id;
1693       Proxy_Object_Addr  : out Entity_Id)
1694    is
1695       Loc : constant Source_Ptr := Sloc (Vis_Decl);
1696
1697       Subp_Name : constant Entity_Id :=
1698                      Defining_Unit_Name (Specification (Vis_Decl));
1699
1700       Pkg_Name   : constant Entity_Id :=
1701                      Make_Defining_Identifier (Loc,
1702                        Chars =>
1703                          New_External_Name (Chars (Subp_Name), 'P', -1));
1704
1705       Proxy_Type : constant Entity_Id :=
1706                      Make_Defining_Identifier (Loc,
1707                        Chars =>
1708                          New_External_Name (
1709                            Related_Id => Chars (Subp_Name),
1710                            Suffix     => 'P'));
1711
1712       Proxy_Type_Full_View : constant Entity_Id :=
1713                                Make_Defining_Identifier (Loc,
1714                                  Chars (Proxy_Type));
1715
1716       Subp_Decl_Spec : constant Node_Id :=
1717                          Build_RAS_Primitive_Specification
1718                            (Subp_Spec          => Specification (Vis_Decl),
1719                             Remote_Object_Type => Proxy_Type);
1720
1721       Subp_Body_Spec : constant Node_Id :=
1722                          Build_RAS_Primitive_Specification
1723                            (Subp_Spec          => Specification (Vis_Decl),
1724                             Remote_Object_Type => Proxy_Type);
1725
1726       Vis_Decls    : constant List_Id := New_List;
1727       Pvt_Decls    : constant List_Id := New_List;
1728       Actuals      : constant List_Id := New_List;
1729       Formal       : Node_Id;
1730       Perform_Call : Node_Id;
1731
1732    begin
1733       --  type subpP is tagged limited private;
1734
1735       Append_To (Vis_Decls,
1736         Make_Private_Type_Declaration (Loc,
1737           Defining_Identifier => Proxy_Type,
1738           Tagged_Present      => True,
1739           Limited_Present     => True));
1740
1741       --  [subprogram] Call
1742       --    (Self : access subpP;
1743       --     ...other-formals...)
1744       --     [return T];
1745
1746       Append_To (Vis_Decls,
1747         Make_Subprogram_Declaration (Loc,
1748           Specification => Subp_Decl_Spec));
1749
1750       --  A : constant System.Address;
1751
1752       Proxy_Object_Addr := Make_Defining_Identifier (Loc, Name_uA);
1753
1754       Append_To (Vis_Decls,
1755         Make_Object_Declaration (Loc,
1756           Defining_Identifier =>
1757             Proxy_Object_Addr,
1758           Constant_Present     =>
1759             True,
1760           Object_Definition   =>
1761             New_Occurrence_Of (RTE (RE_Address), Loc)));
1762
1763       --  private
1764
1765       --  type subpP is tagged limited record
1766       --     All_Calls_Remote : Boolean := [All_Calls_Remote?];
1767       --     ...
1768       --  end record;
1769
1770       Append_To (Pvt_Decls,
1771         Make_Full_Type_Declaration (Loc,
1772           Defining_Identifier =>
1773             Proxy_Type_Full_View,
1774           Type_Definition     =>
1775             Build_Remote_Subprogram_Proxy_Type (Loc,
1776               New_Occurrence_Of (All_Calls_Remote_E, Loc))));
1777
1778       --  Trick semantic analysis into swapping the public and
1779       --  full view when freezing the public view.
1780
1781       Set_Comes_From_Source (Proxy_Type_Full_View, True);
1782
1783       --  procedure Call
1784       --    (Self : access O;
1785       --     ...other-formals...) is
1786       --  begin
1787       --    P (...other-formals...);
1788       --  end Call;
1789
1790       --  function Call
1791       --    (Self : access O;
1792       --     ...other-formals...)
1793       --     return T is
1794       --  begin
1795       --    return F (...other-formals...);
1796       --  end Call;
1797
1798       if Nkind (Subp_Decl_Spec) = N_Procedure_Specification then
1799          Perform_Call :=
1800            Make_Procedure_Call_Statement (Loc,
1801              Name =>
1802                New_Occurrence_Of (Subp_Name, Loc),
1803              Parameter_Associations =>
1804                Actuals);
1805       else
1806          Perform_Call :=
1807            Make_Return_Statement (Loc,
1808              Expression =>
1809            Make_Function_Call (Loc,
1810              Name =>
1811                New_Occurrence_Of (Subp_Name, Loc),
1812              Parameter_Associations =>
1813                Actuals));
1814       end if;
1815
1816       Formal := First (Parameter_Specifications (Subp_Decl_Spec));
1817       pragma Assert (Present (Formal));
1818       Next (Formal);
1819
1820       while Present (Formal) loop
1821          Append_To (Actuals, New_Occurrence_Of (
1822            Defining_Identifier (Formal), Loc));
1823          Next (Formal);
1824       end loop;
1825
1826       --  O : aliased subpP;
1827
1828       Append_To (Pvt_Decls,
1829         Make_Object_Declaration (Loc,
1830           Defining_Identifier =>
1831             Make_Defining_Identifier (Loc,
1832               Name_uO),
1833           Aliased_Present =>
1834             True,
1835           Object_Definition =>
1836             New_Occurrence_Of (Proxy_Type, Loc)));
1837
1838       --  A : constant System.Address := O'Address;
1839
1840       Append_To (Pvt_Decls,
1841         Make_Object_Declaration (Loc,
1842           Defining_Identifier =>
1843             Make_Defining_Identifier (Loc,
1844               Chars (Proxy_Object_Addr)),
1845           Constant_Present =>
1846             True,
1847           Object_Definition =>
1848             New_Occurrence_Of (RTE (RE_Address), Loc),
1849           Expression =>
1850             Make_Attribute_Reference (Loc,
1851               Prefix => New_Occurrence_Of (
1852                 Defining_Identifier (Last (Pvt_Decls)), Loc),
1853               Attribute_Name =>
1854                 Name_Address)));
1855
1856       Append_To (Decls,
1857         Make_Package_Declaration (Loc,
1858           Specification => Make_Package_Specification (Loc,
1859             Defining_Unit_Name   => Pkg_Name,
1860             Visible_Declarations => Vis_Decls,
1861             Private_Declarations => Pvt_Decls,
1862             End_Label            => Empty)));
1863       Analyze (Last (Decls));
1864
1865       Append_To (Decls,
1866         Make_Package_Body (Loc,
1867           Defining_Unit_Name =>
1868             Make_Defining_Identifier (Loc,
1869               Chars (Pkg_Name)),
1870           Declarations => New_List (
1871             Make_Subprogram_Body (Loc,
1872               Specification  =>
1873                 Subp_Body_Spec,
1874               Declarations   => New_List,
1875               Handled_Statement_Sequence =>
1876                 Make_Handled_Sequence_Of_Statements (Loc,
1877                   Statements => New_List (Perform_Call))))));
1878       Analyze (Last (Decls));
1879    end Add_RAS_Proxy_And_Analyze;
1880
1881    -----------------------
1882    -- Add_RAST_Features --
1883    -----------------------
1884
1885    procedure Add_RAST_Features (Vis_Decl : Node_Id) is
1886    begin
1887       --  Do not add attributes more than once in any case. This should
1888       --  be replaced by an assert or this comment removed if we decide
1889       --  that this is normal to be called several times ???
1890
1891       if Present (TSS (Equivalent_Type (Defining_Identifier (Vis_Decl)),
1892                        TSS_RAS_Access))
1893       then
1894          return;
1895       end if;
1896
1897       Add_RAS_Dereference_TSS (Vis_Decl);
1898       Add_RAS_Access_TSS (Vis_Decl);
1899    end Add_RAST_Features;
1900
1901    -----------------------------------------
1902    -- Add_Receiving_Stubs_To_Declarations --
1903    -----------------------------------------
1904
1905    procedure Add_Receiving_Stubs_To_Declarations
1906      (Pkg_Spec : Node_Id;
1907       Decls    : List_Id)
1908    is
1909       Loc : constant Source_Ptr := Sloc (Pkg_Spec);
1910
1911       Stream_Parameter : Node_Id;
1912       Result_Parameter : Node_Id;
1913
1914       Pkg_RPC_Receiver            : Node_Id;
1915       Pkg_RPC_Receiver_Spec       : Node_Id;
1916       Pkg_RPC_Receiver_Decls      : List_Id;
1917       Pkg_RPC_Receiver_Statements : List_Id;
1918       Pkg_RPC_Receiver_Cases      : constant List_Id := New_List;
1919       Pkg_RPC_Receiver_Body       : Node_Id;
1920       --  A Pkg_RPC_Receiver is built to decode the request
1921
1922       Lookup_RAS_Info : constant Entity_Id :=
1923         Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
1924       --  A remote subprogram is created to allow peers to look up
1925       --  RAS information using subprogram ids.
1926
1927       Subp_Id : Node_Id;
1928       --  Subprogram_Id as read from the incoming stream
1929
1930       Current_Declaration       : Node_Id;
1931       Current_Subprogram_Number : Int := First_RCI_Subprogram_Id;
1932       Current_Stubs             : Node_Id;
1933
1934       Subp_Info_Array : constant Entity_Id :=
1935         Make_Defining_Identifier (Loc, New_Internal_Name ('I'));
1936
1937       Subp_Info_List : constant List_Id := New_List;
1938
1939       Register_Pkg_Actuals : constant List_Id := New_List;
1940
1941       Dummy_Register_Name : Name_Id;
1942       Dummy_Register_Spec : Node_Id;
1943       Dummy_Register_Decl : Node_Id;
1944       Dummy_Register_Body : Node_Id;
1945
1946       All_Calls_Remote_E  : Entity_Id;
1947       Proxy_Object_Addr   : Entity_Id;
1948
1949       procedure Append_Stubs_To
1950         (RPC_Receiver_Cases : List_Id;
1951          Declaration        : Node_Id;
1952          Stubs              : Node_Id;
1953          Subprogram_Number  : Int);
1954       --  Add one case to the specified RPC receiver case list
1955       --  associating Subprogram_Number with the subprogram declared
1956       --  by Declaration, for which we have receiving stubs in Stubs.
1957
1958       ---------------------
1959       -- Append_Stubs_To --
1960       ---------------------
1961
1962       procedure Append_Stubs_To
1963         (RPC_Receiver_Cases : List_Id;
1964          Declaration        : Node_Id;
1965          Stubs              : Node_Id;
1966          Subprogram_Number  : Int)
1967       is
1968          Actuals : constant List_Id :=
1969                      New_List (New_Occurrence_Of (Stream_Parameter, Loc));
1970       begin
1971          if Nkind (Specification (Declaration)) = N_Function_Specification
1972            or else not
1973              Is_Asynchronous (Defining_Entity (Specification (Declaration)))
1974          then
1975             --  An asynchronous procedure does not want an output parameter
1976             --  since no result and no exception will ever be returned.
1977
1978             Append_To (Actuals,
1979               New_Occurrence_Of (Result_Parameter, Loc));
1980          end if;
1981
1982          Append_To (RPC_Receiver_Cases,
1983            Make_Case_Statement_Alternative (Loc,
1984              Discrete_Choices =>
1985                 New_List (
1986                   Make_Integer_Literal (Loc, Subprogram_Number)),
1987
1988              Statements       =>
1989                New_List (
1990                  Make_Procedure_Call_Statement (Loc,
1991                    Name                   =>
1992                      New_Occurrence_Of (
1993                        Defining_Entity (Stubs), Loc),
1994                    Parameter_Associations =>
1995                      Actuals))));
1996       end Append_Stubs_To;
1997
1998    --  Start of processing for Add_Receiving_Stubs_To_Declarations
1999
2000    begin
2001       --  Building receiving stubs consist in several operations:
2002
2003       --    - a package RPC receiver must be built. This subprogram
2004       --      will get a Subprogram_Id from the incoming stream
2005       --      and will dispatch the call to the right subprogram
2006
2007       --    - a receiving stub for any subprogram visible in the package
2008       --      spec. This stub will read all the parameters from the stream,
2009       --      and put the result as well as the exception occurrence in the
2010       --      output stream
2011
2012       --    - a dummy package with an empty spec and a body made of an
2013       --      elaboration part, whose job is to register the receiving
2014       --      part of this RCI package on the name server. This is done
2015       --      by calling System.Partition_Interface.Register_Receiving_Stub
2016
2017       Stream_Parameter :=
2018         Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
2019       Result_Parameter :=
2020         Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
2021       Subp_Id :=
2022         Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
2023
2024       Pkg_RPC_Receiver :=
2025         Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
2026
2027       --  The parameters of the package RPC receiver are made of two
2028       --  streams, an input one and an output one.
2029
2030       Pkg_RPC_Receiver_Spec :=
2031         Build_RPC_Receiver_Specification
2032           (RPC_Receiver     => Pkg_RPC_Receiver,
2033            Stream_Parameter => Stream_Parameter,
2034            Result_Parameter => Result_Parameter);
2035
2036       Pkg_RPC_Receiver_Decls := New_List (
2037         Make_Object_Declaration (Loc,
2038           Defining_Identifier => Subp_Id,
2039           Object_Definition   =>
2040             New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc)));
2041
2042       Pkg_RPC_Receiver_Statements := New_List (
2043         Make_Attribute_Reference (Loc,
2044           Prefix         =>
2045             New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
2046           Attribute_Name =>
2047             Name_Read,
2048           Expressions    => New_List (
2049             New_Occurrence_Of (Stream_Parameter, Loc),
2050             New_Occurrence_Of (Subp_Id, Loc))));
2051
2052       --  A null subp_id denotes a call through a RAS, in which case the
2053       --  next Uint_64 element in the stream is the address of the local
2054       --  proxy object, from which we can retrieve the actual subprogram id.
2055
2056       Append_To (Pkg_RPC_Receiver_Statements,
2057         Make_Implicit_If_Statement (Pkg_Spec,
2058           Condition =>
2059             Make_Op_Eq (Loc,
2060               New_Occurrence_Of (Subp_Id, Loc),
2061               Make_Integer_Literal (Loc, 0)),
2062           Then_Statements => New_List (
2063             Make_Assignment_Statement (Loc,
2064               Name =>
2065                 New_Occurrence_Of (Subp_Id, Loc),
2066               Expression =>
2067                 Make_Selected_Component (Loc,
2068                   Prefix =>
2069                     Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access),
2070                       OK_Convert_To (RTE (RE_Address),
2071                         Make_Attribute_Reference (Loc,
2072                           Prefix =>
2073                             New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
2074                           Attribute_Name =>
2075                             Name_Input,
2076                           Expressions => New_List (
2077                             New_Occurrence_Of (Stream_Parameter, Loc))))),
2078                   Selector_Name =>
2079                     Make_Identifier (Loc, Name_Subp_Id))))));
2080
2081       All_Calls_Remote_E := Boolean_Literals (
2082         Has_All_Calls_Remote (Defining_Entity (Pkg_Spec)));
2083
2084       --  Build a subprogram for RAS information lookups
2085
2086       Current_Declaration :=
2087         Make_Subprogram_Declaration (Loc,
2088           Specification =>
2089             Make_Function_Specification (Loc,
2090               Defining_Unit_Name =>
2091                 Lookup_RAS_Info,
2092               Parameter_Specifications => New_List (
2093                 Make_Parameter_Specification (Loc,
2094                   Defining_Identifier =>
2095                     Make_Defining_Identifier (Loc, Name_Subp_Id),
2096                   In_Present =>
2097                     True,
2098                   Parameter_Type =>
2099                     New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc))),
2100               Subtype_Mark =>
2101                 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)));
2102       Append_To (Decls, Current_Declaration);
2103       Analyze (Current_Declaration);
2104
2105       Current_Stubs := Build_Subprogram_Receiving_Stubs
2106         (Vis_Decl     => Current_Declaration,
2107          Asynchronous => False);
2108       Append_To (Decls, Current_Stubs);
2109       Analyze (Current_Stubs);
2110
2111       Append_Stubs_To (Pkg_RPC_Receiver_Cases,
2112         Declaration =>
2113           Current_Declaration,
2114         Stubs       =>
2115           Current_Stubs,
2116         Subprogram_Number => 1);
2117
2118       --  For each subprogram, the receiving stub will be built and a
2119       --  case statement will be made on the Subprogram_Id to dispatch
2120       --  to the right subprogram.
2121
2122       Current_Declaration := First (Visible_Declarations (Pkg_Spec));
2123       while Current_Declaration /= Empty loop
2124          if Nkind (Current_Declaration) = N_Subprogram_Declaration
2125            and then Comes_From_Source (Current_Declaration)
2126          then
2127             pragma Assert (Current_Subprogram_Number =
2128               Get_Subprogram_Id (Defining_Unit_Name (Specification (
2129                 Current_Declaration))));
2130
2131             --  Build receiving stub
2132
2133             Current_Stubs :=
2134               Build_Subprogram_Receiving_Stubs
2135                 (Vis_Decl     => Current_Declaration,
2136                  Asynchronous =>
2137                    Nkind (Specification (Current_Declaration)) =
2138                        N_Procedure_Specification
2139                      and then Is_Asynchronous
2140                        (Defining_Unit_Name (Specification
2141                           (Current_Declaration))));
2142
2143             Append_To (Decls, Current_Stubs);
2144             Analyze (Current_Stubs);
2145
2146             --  Build RAS proxy
2147
2148             Add_RAS_Proxy_And_Analyze (Decls,
2149               Vis_Decl           =>
2150                 Current_Declaration,
2151               All_Calls_Remote_E =>
2152                 All_Calls_Remote_E,
2153               Proxy_Object_Addr  =>
2154                 Proxy_Object_Addr);
2155
2156             --  Add subprogram descriptor (RCI_Subp_Info) to the
2157             --  subprograms table for this receiver. The aggregate
2158             --  below must be kept consistent with the declaration
2159             --  of type RCI_Subp_Info in System.Partition_Interface.
2160
2161             Append_To (Subp_Info_List,
2162               Make_Component_Association (Loc,
2163                 Choices => New_List (
2164                   Make_Integer_Literal (Loc,
2165                     Current_Subprogram_Number)),
2166                 Expression =>
2167                   Make_Aggregate (Loc,
2168                     Component_Associations => New_List (
2169                       Make_Component_Association (Loc,
2170                         Choices => New_List (
2171                           Make_Identifier (Loc, Name_Addr)),
2172                         Expression =>
2173                           New_Occurrence_Of (Proxy_Object_Addr, Loc))))));
2174
2175             Append_Stubs_To (Pkg_RPC_Receiver_Cases,
2176               Declaration =>
2177                 Current_Declaration,
2178               Stubs =>
2179                 Current_Stubs,
2180               Subprogram_Number =>
2181                 Current_Subprogram_Number);
2182             Current_Subprogram_Number := Current_Subprogram_Number + 1;
2183          end if;
2184
2185          Next (Current_Declaration);
2186       end loop;
2187
2188       --  If we receive an invalid Subprogram_Id, it is best to do nothing
2189       --  rather than raising an exception since we do not want someone
2190       --  to crash a remote partition by sending invalid subprogram ids.
2191       --  This is consistent with the other parts of the case statement
2192       --  since even in presence of incorrect parameters in the stream,
2193       --  every exception will be caught and (if the subprogram is not an
2194       --  APC) put into the result stream and sent away.
2195
2196       Append_To (Pkg_RPC_Receiver_Cases,
2197         Make_Case_Statement_Alternative (Loc,
2198           Discrete_Choices =>
2199             New_List (Make_Others_Choice (Loc)),
2200           Statements       =>
2201             New_List (Make_Null_Statement (Loc))));
2202
2203       Append_To (Pkg_RPC_Receiver_Statements,
2204         Make_Case_Statement (Loc,
2205           Expression   =>
2206             New_Occurrence_Of (Subp_Id, Loc),
2207           Alternatives => Pkg_RPC_Receiver_Cases));
2208
2209       Append_To (Decls,
2210         Make_Object_Declaration (Loc,
2211           Defining_Identifier => Subp_Info_Array,
2212           Constant_Present    => True,
2213           Aliased_Present     => True,
2214           Object_Definition   =>
2215             Make_Subtype_Indication (Loc,
2216               Subtype_Mark =>
2217                 New_Occurrence_Of (RTE (RE_RCI_Subp_Info_Array), Loc),
2218               Constraint =>
2219                 Make_Index_Or_Discriminant_Constraint (Loc,
2220                   New_List (
2221                     Make_Range (Loc,
2222                       Low_Bound  => Make_Integer_Literal (Loc,
2223                         First_RCI_Subprogram_Id),
2224                       High_Bound =>
2225                         Make_Integer_Literal (Loc,
2226                           First_RCI_Subprogram_Id
2227                           + List_Length (Subp_Info_List) - 1))))),
2228           Expression          =>
2229             Make_Aggregate (Loc,
2230               Component_Associations => Subp_Info_List)));
2231       Analyze (Last (Decls));
2232
2233       Append_To (Decls,
2234         Make_Subprogram_Body (Loc,
2235           Specification =>
2236             Copy_Specification (Loc, Parent (Lookup_RAS_Info)),
2237           Declarations =>
2238             No_List,
2239           Handled_Statement_Sequence =>
2240             Make_Handled_Sequence_Of_Statements (Loc,
2241               Statements => New_List (
2242                 Make_Return_Statement (Loc,
2243                   Expression => OK_Convert_To (RTE (RE_Unsigned_64),
2244                     Make_Selected_Component (Loc,
2245                       Prefix =>
2246                         Make_Indexed_Component (Loc,
2247                           Prefix =>
2248                             New_Occurrence_Of (Subp_Info_Array, Loc),
2249                           Expressions => New_List (
2250                             Convert_To (Standard_Integer,
2251                               Make_Identifier (Loc, Name_Subp_Id)))),
2252                       Selector_Name =>
2253                         Make_Identifier (Loc, Name_Addr))))))));
2254       Analyze (Last (Decls));
2255
2256       Pkg_RPC_Receiver_Body :=
2257         Make_Subprogram_Body (Loc,
2258           Specification              => Pkg_RPC_Receiver_Spec,
2259           Declarations               => Pkg_RPC_Receiver_Decls,
2260           Handled_Statement_Sequence =>
2261             Make_Handled_Sequence_Of_Statements (Loc,
2262               Statements => Pkg_RPC_Receiver_Statements));
2263
2264       Append_To (Decls, Pkg_RPC_Receiver_Body);
2265       Analyze (Pkg_RPC_Receiver_Body);
2266
2267       --  Construction of the dummy package used to register the package
2268       --  receiving stubs on the nameserver.
2269
2270       Dummy_Register_Name := New_Internal_Name ('P');
2271
2272       Dummy_Register_Spec :=
2273         Make_Package_Specification (Loc,
2274           Defining_Unit_Name   =>
2275             Make_Defining_Identifier (Loc, Dummy_Register_Name),
2276           Visible_Declarations => No_List,
2277           End_Label => Empty);
2278
2279       Dummy_Register_Decl :=
2280         Make_Package_Declaration (Loc,
2281           Specification => Dummy_Register_Spec);
2282
2283       Append_To (Decls, Dummy_Register_Decl);
2284       Analyze (Dummy_Register_Decl);
2285
2286       Get_Pkg_Name_String (Pkg_Spec);
2287       Append_To (Register_Pkg_Actuals,
2288          --  Name
2289         Make_String_Literal (Loc,
2290           Strval => String_From_Name_Buffer));
2291
2292       Append_To (Register_Pkg_Actuals,
2293          --  Receiver
2294         Make_Attribute_Reference (Loc,
2295           Prefix         =>
2296             New_Occurrence_Of (Pkg_RPC_Receiver, Loc),
2297           Attribute_Name =>
2298             Name_Unrestricted_Access));
2299
2300       Append_To (Register_Pkg_Actuals,
2301          --  Version
2302         Make_Attribute_Reference (Loc,
2303           Prefix         =>
2304             New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc),
2305           Attribute_Name =>
2306             Name_Version));
2307
2308       Append_To (Register_Pkg_Actuals,
2309          --  Subp_Info
2310         Make_Attribute_Reference (Loc,
2311           Prefix         =>
2312             New_Occurrence_Of (Subp_Info_Array, Loc),
2313           Attribute_Name =>
2314             Name_Address));
2315
2316       Append_To (Register_Pkg_Actuals,
2317          --  Subp_Info_Len
2318         Make_Attribute_Reference (Loc,
2319           Prefix         =>
2320             New_Occurrence_Of (Subp_Info_Array, Loc),
2321           Attribute_Name =>
2322             Name_Length));
2323
2324       Dummy_Register_Body :=
2325         Make_Package_Body (Loc,
2326           Defining_Unit_Name         =>
2327             Make_Defining_Identifier (Loc, Dummy_Register_Name),
2328           Declarations               => No_List,
2329
2330           Handled_Statement_Sequence =>
2331             Make_Handled_Sequence_Of_Statements (Loc,
2332               Statements => New_List (
2333                 Make_Procedure_Call_Statement (Loc,
2334                   Name                   =>
2335                     New_Occurrence_Of (RTE (RE_Register_Receiving_Stub), Loc),
2336
2337                   Parameter_Associations => Register_Pkg_Actuals))));
2338
2339       Append_To (Decls, Dummy_Register_Body);
2340       Analyze (Dummy_Register_Body);
2341    end Add_Receiving_Stubs_To_Declarations;
2342
2343    -------------------
2344    -- Add_Stub_Type --
2345    -------------------
2346
2347    procedure Add_Stub_Type
2348      (Designated_Type     : Entity_Id;
2349       RACW_Type           : Entity_Id;
2350       Decls               : List_Id;
2351       Stub_Type           : out Entity_Id;
2352       Stub_Type_Access    : out Entity_Id;
2353       Object_RPC_Receiver : out Entity_Id;
2354       Existing            : out Boolean)
2355    is
2356       Loc : constant Source_Ptr := Sloc (RACW_Type);
2357
2358       Stub_Elements : constant Stub_Structure :=
2359                         Stubs_Table.Get (Designated_Type);
2360
2361       Stub_Type_Declaration           : Node_Id;
2362       Stub_Type_Access_Declaration    : Node_Id;
2363       Object_RPC_Receiver_Declaration : Node_Id;
2364
2365       RPC_Receiver_Stream             : Entity_Id;
2366       RPC_Receiver_Result             : Entity_Id;
2367
2368    begin
2369       if Stub_Elements /= Empty_Stub_Structure then
2370          Stub_Type           := Stub_Elements.Stub_Type;
2371          Stub_Type_Access    := Stub_Elements.Stub_Type_Access;
2372          Object_RPC_Receiver := Stub_Elements.Object_RPC_Receiver;
2373          Existing            := True;
2374          return;
2375       end if;
2376
2377       Existing            := False;
2378       Stub_Type           :=
2379         Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
2380       Stub_Type_Access    :=
2381         Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
2382       Object_RPC_Receiver :=
2383         Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
2384       RPC_Receiver_Stream :=
2385         Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
2386       RPC_Receiver_Result :=
2387         Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
2388       Stubs_Table.Set (Designated_Type,
2389         (Stub_Type           => Stub_Type,
2390          Stub_Type_Access    => Stub_Type_Access,
2391          Object_RPC_Receiver => Object_RPC_Receiver,
2392          RPC_Receiver_Stream => RPC_Receiver_Stream,
2393          RPC_Receiver_Result => RPC_Receiver_Result,
2394          RACW_Type           => RACW_Type));
2395
2396       --  The stub type definition below must match exactly the one in
2397       --  s-parint.ads, since unchecked conversions will be used in
2398       --  s-parint.adb to modify pointers passed to Get_Unique_Remote_Pointer.
2399
2400       Stub_Type_Declaration :=
2401         Make_Full_Type_Declaration (Loc,
2402           Defining_Identifier => Stub_Type,
2403           Type_Definition     =>
2404             Make_Record_Definition (Loc,
2405               Tagged_Present  => True,
2406               Limited_Present => True,
2407               Component_List  =>
2408                 Make_Component_List (Loc,
2409                   Component_Items => New_List (
2410
2411                     Make_Component_Declaration (Loc,
2412                       Defining_Identifier =>
2413                         Make_Defining_Identifier (Loc, Name_Origin),
2414                       Component_Definition =>
2415                         Make_Component_Definition (Loc,
2416                           Aliased_Present    => False,
2417                           Subtype_Indication =>
2418                             New_Occurrence_Of (RTE (RE_Partition_ID), Loc))),
2419
2420                     Make_Component_Declaration (Loc,
2421                       Defining_Identifier =>
2422                         Make_Defining_Identifier (Loc, Name_Receiver),
2423                       Component_Definition =>
2424                         Make_Component_Definition (Loc,
2425                           Aliased_Present    => False,
2426                           Subtype_Indication =>
2427                             New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))),
2428
2429                     Make_Component_Declaration (Loc,
2430                       Defining_Identifier =>
2431                         Make_Defining_Identifier (Loc, Name_Addr),
2432                       Component_Definition =>
2433                         Make_Component_Definition (Loc,
2434                           Aliased_Present    => False,
2435                           Subtype_Indication =>
2436                             New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))),
2437
2438                     Make_Component_Declaration (Loc,
2439                       Defining_Identifier =>
2440                         Make_Defining_Identifier (Loc, Name_Asynchronous),
2441                       Component_Definition =>
2442                         Make_Component_Definition (Loc,
2443                           Aliased_Present    => False,
2444                           Subtype_Indication =>
2445                             New_Occurrence_Of (Standard_Boolean, Loc)))))));
2446
2447       Append_To (Decls, Stub_Type_Declaration);
2448       Analyze (Stub_Type_Declaration);
2449
2450       --  This is in no way a type derivation, but we fake it to make
2451       --  sure that the dispatching table gets built with the corresponding
2452       --  primitive operations at the right place.
2453
2454       Derive_Subprograms (Parent_Type  => Designated_Type,
2455                           Derived_Type => Stub_Type);
2456
2457       Stub_Type_Access_Declaration :=
2458         Make_Full_Type_Declaration (Loc,
2459           Defining_Identifier => Stub_Type_Access,
2460           Type_Definition     =>
2461             Make_Access_To_Object_Definition (Loc,
2462               All_Present        => True,
2463               Subtype_Indication => New_Occurrence_Of (Stub_Type, Loc)));
2464
2465       Append_To (Decls, Stub_Type_Access_Declaration);
2466       Analyze (Stub_Type_Access_Declaration);
2467
2468       Object_RPC_Receiver_Declaration :=
2469         Make_Subprogram_Declaration (Loc,
2470           Build_RPC_Receiver_Specification (
2471             RPC_Receiver     => Object_RPC_Receiver,
2472             Stream_Parameter => RPC_Receiver_Stream,
2473             Result_Parameter => RPC_Receiver_Result));
2474
2475       Append_To (Decls, Object_RPC_Receiver_Declaration);
2476    end Add_Stub_Type;
2477
2478    ---------------------------------
2479    -- Build_General_Calling_Stubs --
2480    ---------------------------------
2481
2482    procedure Build_General_Calling_Stubs
2483      (Decls                     : List_Id;
2484       Statements                : List_Id;
2485       Target_Partition          : Entity_Id;
2486       RPC_Receiver              : Node_Id;
2487       Subprogram_Id             : Node_Id;
2488       Asynchronous              : Node_Id   := Empty;
2489       Is_Known_Asynchronous     : Boolean   := False;
2490       Is_Known_Non_Asynchronous : Boolean   := False;
2491       Is_Function               : Boolean;
2492       Spec                      : Node_Id;
2493       Stub_Type                 : Entity_Id := Empty;
2494       RACW_Type                 : Entity_Id := Empty;
2495       Nod                       : Node_Id)
2496    is
2497       Loc : constant Source_Ptr := Sloc (Nod);
2498
2499       Stream_Parameter : Node_Id;
2500       --  Name of the stream used to transmit parameters to the remote package
2501
2502       Result_Parameter : Node_Id;
2503       --  Name of the result parameter (in non-APC cases) which get the
2504       --  result of the remote subprogram.
2505
2506       Exception_Return_Parameter : Node_Id;
2507       --  Name of the parameter which will hold the exception sent by the
2508       --  remote subprogram.
2509
2510       Current_Parameter : Node_Id;
2511       --  Current parameter being handled
2512
2513       Ordered_Parameters_List : constant List_Id :=
2514                                   Build_Ordered_Parameters_List (Spec);
2515
2516       Asynchronous_Statements     : List_Id := No_List;
2517       Non_Asynchronous_Statements : List_Id := No_List;
2518       --  Statements specifics to the Asynchronous/Non-Asynchronous cases
2519
2520       Extra_Formal_Statements : constant List_Id := New_List;
2521       --  List of statements for extra formal parameters. It will appear after
2522       --  the regular statements for writing out parameters.
2523
2524       pragma Warnings (Off, RACW_Type);
2525       --  Unreferenced formal parameter.
2526
2527    begin
2528       --  The general form of a calling stub for a given subprogram is:
2529
2530       --    procedure X (...) is
2531       --      P : constant Partition_ID := RCI_Cache.Get_Active_Partition_ID;
2532       --      Stream, Result : aliased System.RPC.Params_Stream_Type (0);
2533       --    begin
2534       --       Put_Package_RPC_Receiver_In_Stream; (the package RPC receiver
2535       --                  comes from RCI_Cache.Get_RCI_Package_Receiver)
2536       --       Put_Subprogram_Id_In_Stream;
2537       --       Put_Parameters_In_Stream;
2538       --       Do_RPC (Stream, Result);
2539       --       Read_Exception_Occurrence_From_Result; Raise_It;
2540       --       Read_Out_Parameters_And_Function_Return_From_Stream;
2541       --    end X;
2542
2543       --  There are some variations: Do_APC is called for an asynchronous
2544       --  procedure and the part after the call is completely ommitted
2545       --  as well as the declaration of Result. For a function call,
2546       --  'Input is always used to read the result even if it is constrained.
2547
2548       Stream_Parameter :=
2549         Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
2550
2551       Append_To (Decls,
2552         Make_Object_Declaration (Loc,
2553           Defining_Identifier => Stream_Parameter,
2554           Aliased_Present     => True,
2555           Object_Definition   =>
2556             Make_Subtype_Indication (Loc,
2557               Subtype_Mark =>
2558                 New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc),
2559               Constraint   =>
2560                 Make_Index_Or_Discriminant_Constraint (Loc,
2561                   Constraints =>
2562                     New_List (Make_Integer_Literal (Loc, 0))))));
2563
2564       if not Is_Known_Asynchronous then
2565          Result_Parameter :=
2566            Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
2567
2568          Append_To (Decls,
2569            Make_Object_Declaration (Loc,
2570              Defining_Identifier => Result_Parameter,
2571              Aliased_Present     => True,
2572              Object_Definition   =>
2573                Make_Subtype_Indication (Loc,
2574                  Subtype_Mark =>
2575                    New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc),
2576                  Constraint   =>
2577                    Make_Index_Or_Discriminant_Constraint (Loc,
2578                      Constraints =>
2579                        New_List (Make_Integer_Literal (Loc, 0))))));
2580
2581          Exception_Return_Parameter :=
2582            Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
2583
2584          Append_To (Decls,
2585            Make_Object_Declaration (Loc,
2586              Defining_Identifier => Exception_Return_Parameter,
2587              Object_Definition   =>
2588                New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc)));
2589
2590       else
2591          Result_Parameter := Empty;
2592          Exception_Return_Parameter := Empty;
2593       end if;
2594
2595       --  Put first the RPC receiver corresponding to the remote package
2596
2597       Append_To (Statements,
2598         Make_Attribute_Reference (Loc,
2599           Prefix         =>
2600             New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
2601           Attribute_Name => Name_Write,
2602           Expressions    => New_List (
2603             Make_Attribute_Reference (Loc,
2604               Prefix         =>
2605                 New_Occurrence_Of (Stream_Parameter, Loc),
2606               Attribute_Name =>
2607                 Name_Access),
2608             RPC_Receiver)));
2609
2610       --  Then put the Subprogram_Id of the subprogram we want to call in
2611       --  the stream.
2612
2613       Append_To (Statements,
2614         Make_Attribute_Reference (Loc,
2615           Prefix         =>
2616             New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
2617           Attribute_Name =>
2618             Name_Write,
2619           Expressions      => New_List (
2620             Make_Attribute_Reference (Loc,
2621               Prefix         =>
2622                 New_Occurrence_Of (Stream_Parameter, Loc),
2623               Attribute_Name => Name_Access),
2624             Subprogram_Id)));
2625
2626       Current_Parameter := First (Ordered_Parameters_List);
2627       while Current_Parameter /= Empty loop
2628          declare
2629             Typ             : constant Node_Id :=
2630                                 Parameter_Type (Current_Parameter);
2631             Etyp            : Entity_Id;
2632             Constrained     : Boolean;
2633             Value           : Node_Id;
2634             Extra_Parameter : Entity_Id;
2635
2636          begin
2637             if Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type) then
2638
2639                --  In the case of a controlling formal argument, we marshall
2640                --  its addr field rather than the local stub.
2641
2642                Append_To (Statements,
2643                   Pack_Node_Into_Stream (Loc,
2644                     Stream => Stream_Parameter,
2645                     Object =>
2646                       Make_Selected_Component (Loc,
2647                         Prefix        =>
2648                           New_Occurrence_Of (
2649                             Defining_Identifier (Current_Parameter), Loc),
2650                         Selector_Name =>
2651                           Make_Identifier (Loc, Name_Addr)),
2652                     Etyp   => RTE (RE_Unsigned_64)));
2653
2654             else
2655                Value := New_Occurrence_Of
2656                  (Defining_Identifier (Current_Parameter), Loc);
2657
2658                --  Access type parameters are transmitted as in out
2659                --  parameters. However, a dereference is needed so that
2660                --  we marshall the designated object.
2661
2662                if Nkind (Typ) = N_Access_Definition then
2663                   Value := Make_Explicit_Dereference (Loc, Value);
2664                   Etyp  := Etype (Subtype_Mark (Typ));
2665                else
2666                   Etyp := Etype (Typ);
2667                end if;
2668
2669                Constrained :=
2670                  Is_Constrained (Etyp) or else Is_Elementary_Type (Etyp);
2671
2672                --  Any parameter but unconstrained out parameters are
2673                --  transmitted to the peer.
2674
2675                if In_Present (Current_Parameter)
2676                  or else not Out_Present (Current_Parameter)
2677                  or else not Constrained
2678                then
2679                   Append_To (Statements,
2680                     Make_Attribute_Reference (Loc,
2681                       Prefix         =>
2682                         New_Occurrence_Of (Etyp, Loc),
2683                       Attribute_Name => Output_From_Constrained (Constrained),
2684                       Expressions    => New_List (
2685                         Make_Attribute_Reference (Loc,
2686                           Prefix         =>
2687                             New_Occurrence_Of (Stream_Parameter, Loc),
2688                           Attribute_Name => Name_Access),
2689                         Value)));
2690                end if;
2691             end if;
2692
2693             --  If the current parameter has a dynamic constrained status,
2694             --  then this status is transmitted as well.
2695             --  This should be done for accessibility as well ???
2696
2697             if Nkind (Typ) /= N_Access_Definition
2698               and then Need_Extra_Constrained (Current_Parameter)
2699             then
2700                --  In this block, we do not use the extra formal that has been
2701                --  created because it does not exist at the time of expansion
2702                --  when building calling stubs for remote access to subprogram
2703                --  types. We create an extra variable of this type and push it
2704                --  in the stream after the regular parameters.
2705
2706                Extra_Parameter := Make_Defining_Identifier
2707                                     (Loc, New_Internal_Name ('P'));
2708
2709                Append_To (Decls,
2710                   Make_Object_Declaration (Loc,
2711                     Defining_Identifier => Extra_Parameter,
2712                     Constant_Present    => True,
2713                     Object_Definition   =>
2714                        New_Occurrence_Of (Standard_Boolean, Loc),
2715                     Expression          =>
2716                        Make_Attribute_Reference (Loc,
2717                          Prefix         =>
2718                            New_Occurrence_Of (
2719                              Defining_Identifier (Current_Parameter), Loc),
2720                          Attribute_Name => Name_Constrained)));
2721
2722                Append_To (Extra_Formal_Statements,
2723                   Make_Attribute_Reference (Loc,
2724                     Prefix         =>
2725                       New_Occurrence_Of (Standard_Boolean, Loc),
2726                     Attribute_Name =>
2727                       Name_Write,
2728                     Expressions    => New_List (
2729                       Make_Attribute_Reference (Loc,
2730                         Prefix         =>
2731                           New_Occurrence_Of (Stream_Parameter, Loc),
2732                         Attribute_Name =>
2733                           Name_Access),
2734                       New_Occurrence_Of (Extra_Parameter, Loc))));
2735             end if;
2736
2737             Next (Current_Parameter);
2738          end;
2739       end loop;
2740
2741       --  Append the formal statements list to the statements
2742
2743       Append_List_To (Statements, Extra_Formal_Statements);
2744
2745       if not Is_Known_Non_Asynchronous then
2746
2747          --  Build the call to System.RPC.Do_APC
2748
2749          Asynchronous_Statements := New_List (
2750            Make_Procedure_Call_Statement (Loc,
2751              Name                   =>
2752                New_Occurrence_Of (RTE (RE_Do_Apc), Loc),
2753              Parameter_Associations => New_List (
2754                New_Occurrence_Of (Target_Partition, Loc),
2755                Make_Attribute_Reference (Loc,
2756                  Prefix         =>
2757                    New_Occurrence_Of (Stream_Parameter, Loc),
2758                  Attribute_Name =>
2759                    Name_Access))));
2760       else
2761          Asynchronous_Statements := No_List;
2762       end if;
2763
2764       if not Is_Known_Asynchronous then
2765
2766          --  Build the call to System.RPC.Do_RPC
2767
2768          Non_Asynchronous_Statements := New_List (
2769            Make_Procedure_Call_Statement (Loc,
2770              Name                   =>
2771                New_Occurrence_Of (RTE (RE_Do_Rpc), Loc),
2772              Parameter_Associations => New_List (
2773                New_Occurrence_Of (Target_Partition, Loc),
2774
2775                Make_Attribute_Reference (Loc,
2776                  Prefix         =>
2777                    New_Occurrence_Of (Stream_Parameter, Loc),
2778                  Attribute_Name =>
2779                    Name_Access),
2780
2781                Make_Attribute_Reference (Loc,
2782                  Prefix         =>
2783                    New_Occurrence_Of (Result_Parameter, Loc),
2784                  Attribute_Name =>
2785                    Name_Access))));
2786
2787          --  Read the exception occurrence from the result stream and
2788          --  reraise it. It does no harm if this is a Null_Occurrence since
2789          --  this does nothing.
2790
2791          Append_To (Non_Asynchronous_Statements,
2792            Make_Attribute_Reference (Loc,
2793              Prefix         =>
2794                New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc),
2795
2796              Attribute_Name =>
2797                Name_Read,
2798
2799              Expressions    => New_List (
2800                Make_Attribute_Reference (Loc,
2801                  Prefix         =>
2802                    New_Occurrence_Of (Result_Parameter, Loc),
2803                  Attribute_Name =>
2804                    Name_Access),
2805                New_Occurrence_Of (Exception_Return_Parameter, Loc))));
2806
2807          Append_To (Non_Asynchronous_Statements,
2808            Make_Procedure_Call_Statement (Loc,
2809              Name                   =>
2810                New_Occurrence_Of (RTE (RE_Reraise_Occurrence), Loc),
2811              Parameter_Associations => New_List (
2812                New_Occurrence_Of (Exception_Return_Parameter, Loc))));
2813
2814          if Is_Function then
2815
2816             --  If this is a function call, then read the value and return
2817             --  it. The return value is written/read using 'Output/'Input.
2818
2819             Append_To (Non_Asynchronous_Statements,
2820               Make_Tag_Check (Loc,
2821                 Make_Return_Statement (Loc,
2822                   Expression =>
2823                     Make_Attribute_Reference (Loc,
2824                       Prefix         =>
2825                         New_Occurrence_Of (
2826                           Etype (Subtype_Mark (Spec)), Loc),
2827
2828                       Attribute_Name => Name_Input,
2829
2830                       Expressions    => New_List (
2831                         Make_Attribute_Reference (Loc,
2832                           Prefix         =>
2833                             New_Occurrence_Of (Result_Parameter, Loc),
2834                           Attribute_Name => Name_Access))))));
2835
2836          else
2837             --  Loop around parameters and assign out (or in out) parameters.
2838             --  In the case of RACW, controlling arguments cannot possibly
2839             --  have changed since they are remote, so we do not read them
2840             --  from the stream.
2841
2842             Current_Parameter := First (Ordered_Parameters_List);
2843             while Current_Parameter /= Empty loop
2844                declare
2845                   Typ   : constant Node_Id :=
2846                             Parameter_Type (Current_Parameter);
2847                   Etyp  : Entity_Id;
2848                   Value : Node_Id;
2849
2850                begin
2851                   Value :=
2852                     New_Occurrence_Of
2853                       (Defining_Identifier (Current_Parameter), Loc);
2854
2855                   if Nkind (Typ) = N_Access_Definition then
2856                      Value := Make_Explicit_Dereference (Loc, Value);
2857                      Etyp  := Etype (Subtype_Mark (Typ));
2858                   else
2859                      Etyp := Etype (Typ);
2860                   end if;
2861
2862                   if (Out_Present (Current_Parameter)
2863                        or else Nkind (Typ) = N_Access_Definition)
2864                     and then Etyp /= Stub_Type
2865                   then
2866                      Append_To (Non_Asynchronous_Statements,
2867                         Make_Attribute_Reference (Loc,
2868                           Prefix         =>
2869                             New_Occurrence_Of (Etyp, Loc),
2870
2871                           Attribute_Name => Name_Read,
2872
2873                           Expressions    => New_List (
2874                             Make_Attribute_Reference (Loc,
2875                               Prefix         =>
2876                                 New_Occurrence_Of (Result_Parameter, Loc),
2877                               Attribute_Name =>
2878                                 Name_Access),
2879                             Value)));
2880                   end if;
2881                end;
2882
2883                Next (Current_Parameter);
2884             end loop;
2885          end if;
2886       end if;
2887
2888       if Is_Known_Asynchronous then
2889          Append_List_To (Statements, Asynchronous_Statements);
2890
2891       elsif Is_Known_Non_Asynchronous then
2892          Append_List_To (Statements, Non_Asynchronous_Statements);
2893
2894       else
2895          pragma Assert (Asynchronous /= Empty);
2896          Prepend_To (Asynchronous_Statements,
2897            Make_Attribute_Reference (Loc,
2898              Prefix         => New_Occurrence_Of (Standard_Boolean, Loc),
2899              Attribute_Name => Name_Write,
2900              Expressions    => New_List (
2901                Make_Attribute_Reference (Loc,
2902                  Prefix         => New_Occurrence_Of (Stream_Parameter, Loc),
2903                  Attribute_Name => Name_Access),
2904                New_Occurrence_Of (Standard_True, Loc))));
2905
2906          Prepend_To (Non_Asynchronous_Statements,
2907            Make_Attribute_Reference (Loc,
2908              Prefix         => New_Occurrence_Of (Standard_Boolean, Loc),
2909              Attribute_Name => Name_Write,
2910              Expressions    => New_List (
2911                Make_Attribute_Reference (Loc,
2912                  Prefix         => New_Occurrence_Of (Stream_Parameter, Loc),
2913                  Attribute_Name => Name_Access),
2914                New_Occurrence_Of (Standard_False, Loc))));
2915
2916          Append_To (Statements,
2917            Make_Implicit_If_Statement (Nod,
2918              Condition       => Asynchronous,
2919              Then_Statements => Asynchronous_Statements,
2920              Else_Statements => Non_Asynchronous_Statements));
2921       end if;
2922    end Build_General_Calling_Stubs;
2923
2924    ------------------------------
2925    -- Build_Get_Unique_RP_Call --
2926    ------------------------------
2927
2928    function Build_Get_Unique_RP_Call
2929      (Loc       : Source_Ptr;
2930       Pointer   : Entity_Id;
2931       Stub_Type : Entity_Id) return List_Id
2932    is
2933    begin
2934       return New_List (
2935         Make_Procedure_Call_Statement (Loc,
2936           Name                   =>
2937             New_Occurrence_Of (RTE (RE_Get_Unique_Remote_Pointer), Loc),
2938           Parameter_Associations => New_List (
2939             Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access),
2940               New_Occurrence_Of (Pointer, Loc)))),
2941
2942         Make_Assignment_Statement (Loc,
2943           Name =>
2944             Make_Selected_Component (Loc,
2945               Prefix =>
2946                 New_Occurrence_Of (Pointer, Loc),
2947               Selector_Name =>
2948                 New_Occurrence_Of (Tag_Component
2949                   (Designated_Type (Etype (Pointer))), Loc)),
2950           Expression =>
2951             Make_Attribute_Reference (Loc,
2952               Prefix =>
2953                 New_Occurrence_Of (Stub_Type, Loc),
2954               Attribute_Name =>
2955                 Name_Tag)));
2956
2957       --  Note: The assignment to Pointer._Tag is safe here because
2958       --  we carefully ensured that Stub_Type has exactly the same layout
2959       --  as System.Partition_Interface.RACW_Stub_Type.
2960
2961    end Build_Get_Unique_RP_Call;
2962
2963    ----------------------------------------
2964    -- Build_Remote_Subprogram_Proxy_Type --
2965    ----------------------------------------
2966
2967    function Build_Remote_Subprogram_Proxy_Type
2968      (Loc            : Source_Ptr;
2969       ACR_Expression : Node_Id) return Node_Id
2970    is
2971    begin
2972       return
2973         Make_Record_Definition (Loc,
2974           Tagged_Present  => True,
2975           Limited_Present => True,
2976           Component_List  =>
2977             Make_Component_List (Loc,
2978
2979               Component_Items => New_List (
2980                 Make_Component_Declaration (Loc,
2981                   Make_Defining_Identifier (Loc,
2982                     Name_All_Calls_Remote),
2983                   Make_Component_Definition (Loc,
2984                     Subtype_Indication =>
2985                       New_Occurrence_Of (Standard_Boolean, Loc)),
2986                   ACR_Expression),
2987
2988                 Make_Component_Declaration (Loc,
2989                   Make_Defining_Identifier (Loc,
2990                     Name_Receiver),
2991                   Make_Component_Definition (Loc,
2992                     Subtype_Indication =>
2993                       New_Occurrence_Of (RTE (RE_Address), Loc)),
2994                   New_Occurrence_Of (RTE (RE_Null_Address), Loc)),
2995
2996                 Make_Component_Declaration (Loc,
2997                   Make_Defining_Identifier (Loc,
2998                     Name_Subp_Id),
2999                   Make_Component_Definition (Loc,
3000                     Subtype_Indication =>
3001                       New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc))))));
3002    end Build_Remote_Subprogram_Proxy_Type;
3003
3004    -----------------------------------
3005    -- Build_Ordered_Parameters_List --
3006    -----------------------------------
3007
3008    function Build_Ordered_Parameters_List (Spec : Node_Id) return List_Id is
3009       Constrained_List   : List_Id;
3010       Unconstrained_List : List_Id;
3011       Current_Parameter  : Node_Id;
3012
3013       First_Parameter : Node_Id;
3014       For_RAS         : Boolean := False;
3015
3016    begin
3017       if not Present (Parameter_Specifications (Spec)) then
3018          return New_List;
3019       end if;
3020
3021       Constrained_List   := New_List;
3022       Unconstrained_List := New_List;
3023       First_Parameter    := First (Parameter_Specifications (Spec));
3024
3025       if Nkind (Parameter_Type (First_Parameter)) = N_Access_Definition
3026         and then Chars (Defining_Identifier (First_Parameter)) = Name_uS
3027       then
3028          For_RAS := True;
3029       end if;
3030
3031       --  Loop through the parameters and add them to the right list
3032
3033       Current_Parameter := First_Parameter;
3034       while Current_Parameter /= Empty loop
3035          if (Nkind (Parameter_Type (Current_Parameter)) = N_Access_Definition
3036              or else
3037                Is_Constrained (Etype (Parameter_Type (Current_Parameter)))
3038              or else
3039                Is_Elementary_Type (Etype (Parameter_Type (Current_Parameter))))
3040            and then not (For_RAS and then Current_Parameter = First_Parameter)
3041          then
3042             Append_To (Constrained_List, New_Copy (Current_Parameter));
3043          else
3044             Append_To (Unconstrained_List, New_Copy (Current_Parameter));
3045          end if;
3046
3047          Next (Current_Parameter);
3048       end loop;
3049
3050       --  Unconstrained parameters are returned first
3051
3052       Append_List_To (Unconstrained_List, Constrained_List);
3053
3054       return Unconstrained_List;
3055    end Build_Ordered_Parameters_List;
3056
3057    ----------------------------------
3058    -- Build_Passive_Partition_Stub --
3059    ----------------------------------
3060
3061    procedure Build_Passive_Partition_Stub (U : Node_Id) is
3062       Pkg_Spec : Node_Id;
3063       Pkg_Name : String_Id;
3064       L        : List_Id;
3065       Reg      : Node_Id;
3066       Loc      : constant Source_Ptr := Sloc (U);
3067
3068    begin
3069       --  Verify that the implementation supports distribution, by accessing
3070       --  a type defined in the proper version of system.rpc
3071
3072       declare
3073          Dist_OK : Entity_Id;
3074          pragma Warnings (Off, Dist_OK);
3075       begin
3076          Dist_OK := RTE (RE_Params_Stream_Type);
3077       end;
3078
3079       --  Use body if present, spec otherwise
3080
3081       if Nkind (U) = N_Package_Declaration then
3082          Pkg_Spec := Specification (U);
3083          L := Visible_Declarations (Pkg_Spec);
3084       else
3085          Pkg_Spec := Parent (Corresponding_Spec (U));
3086          L := Declarations (U);
3087       end if;
3088
3089       Get_Pkg_Name_String (Pkg_Spec);
3090       Pkg_Name := String_From_Name_Buffer;
3091       Reg :=
3092         Make_Procedure_Call_Statement (Loc,
3093           Name                   =>
3094             New_Occurrence_Of (RTE (RE_Register_Passive_Package), Loc),
3095           Parameter_Associations => New_List (
3096             Make_String_Literal (Loc, Pkg_Name),
3097             Make_Attribute_Reference (Loc,
3098               Prefix         =>
3099                 New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc),
3100               Attribute_Name =>
3101                 Name_Version)));
3102       Append_To (L, Reg);
3103       Analyze (Reg);
3104    end Build_Passive_Partition_Stub;
3105
3106    --------------------------------------
3107    -- Build_RPC_Receiver_Specification --
3108    --------------------------------------
3109
3110    function Build_RPC_Receiver_Specification
3111      (RPC_Receiver     : Entity_Id;
3112       Stream_Parameter : Entity_Id;
3113       Result_Parameter : Entity_Id) return Node_Id
3114    is
3115       Loc : constant Source_Ptr := Sloc (RPC_Receiver);
3116
3117    begin
3118       return
3119         Make_Procedure_Specification (Loc,
3120           Defining_Unit_Name       => RPC_Receiver,
3121           Parameter_Specifications => New_List (
3122             Make_Parameter_Specification (Loc,
3123               Defining_Identifier => Stream_Parameter,
3124               Parameter_Type      =>
3125                 Make_Access_Definition (Loc,
3126                   Subtype_Mark =>
3127                     New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc))),
3128
3129             Make_Parameter_Specification (Loc,
3130               Defining_Identifier => Result_Parameter,
3131               Parameter_Type      =>
3132                 Make_Access_Definition (Loc,
3133                   Subtype_Mark =>
3134                     New_Occurrence_Of
3135                       (RTE (RE_Params_Stream_Type), Loc)))));
3136    end Build_RPC_Receiver_Specification;
3137
3138    ------------------------------------
3139    -- Build_Subprogram_Calling_Stubs --
3140    ------------------------------------
3141
3142    function Build_Subprogram_Calling_Stubs
3143      (Vis_Decl                 : Node_Id;
3144       Subp_Id                  : Int;
3145       Asynchronous             : Boolean;
3146       Dynamically_Asynchronous : Boolean   := False;
3147       Stub_Type                : Entity_Id := Empty;
3148       RACW_Type                : Entity_Id := Empty;
3149       Locator                  : Entity_Id := Empty;
3150       New_Name                 : Name_Id   := No_Name) return Node_Id
3151    is
3152       Loc : constant Source_Ptr := Sloc (Vis_Decl);
3153
3154       Target_Partition : Node_Id;
3155       --  Contains the name of the target partition
3156
3157       Decls      : constant List_Id := New_List;
3158       Statements : constant List_Id := New_List;
3159
3160       Subp_Spec : Node_Id;
3161       --  The specification of the body
3162
3163       Controlling_Parameter : Entity_Id := Empty;
3164       RPC_Receiver          : Node_Id;
3165
3166       Asynchronous_Expr : Node_Id := Empty;
3167
3168       RCI_Locator : Entity_Id;
3169
3170       Spec_To_Use : Node_Id;
3171
3172       procedure Insert_Partition_Check (Parameter : Node_Id);
3173       --  Check that the parameter has been elaborated on the same partition
3174       --  than the controlling parameter (E.4(19)).
3175
3176       ----------------------------
3177       -- Insert_Partition_Check --
3178       ----------------------------
3179
3180       procedure Insert_Partition_Check (Parameter : Node_Id) is
3181          Parameter_Entity  : constant Entity_Id :=
3182                                Defining_Identifier (Parameter);
3183          Condition         : Node_Id;
3184
3185          Designated_Object : Node_Id;
3186          pragma Warnings (Off, Designated_Object);
3187          --  Is it really right that this is unreferenced ???
3188
3189       begin
3190          --  The expression that will be built is of the form:
3191          --    if not (Parameter in Stub_Type and then
3192          --            Parameter.Origin = Controlling.Origin)
3193          --    then
3194          --      raise Constraint_Error;
3195          --    end if;
3196
3197          --  Condition contains the reversed condition. Also, Parameter is
3198          --  dereferenced if it is an access type. We do not check that
3199          --  Parameter is in Stub_Type since such a check has been inserted
3200          --  at the point of call already (a tag check since we have multiple
3201          --  controlling operands).
3202
3203          if Nkind (Parameter_Type (Parameter)) = N_Access_Definition then
3204             Designated_Object :=
3205               Make_Explicit_Dereference (Loc,
3206                 Prefix => New_Occurrence_Of (Parameter_Entity, Loc));
3207          else
3208             Designated_Object := New_Occurrence_Of (Parameter_Entity, Loc);
3209          end if;
3210
3211          Condition :=
3212            Make_Op_Eq (Loc,
3213              Left_Opnd  =>
3214                Make_Selected_Component (Loc,
3215                  Prefix        =>
3216                    New_Occurrence_Of (Parameter_Entity, Loc),
3217                Selector_Name =>
3218                  Make_Identifier (Loc, Name_Origin)),
3219
3220              Right_Opnd =>
3221                Make_Selected_Component (Loc,
3222                  Prefix        =>
3223                    New_Occurrence_Of (Controlling_Parameter, Loc),
3224                Selector_Name =>
3225                  Make_Identifier (Loc, Name_Origin)));
3226
3227          Append_To (Decls,
3228            Make_Raise_Constraint_Error (Loc,
3229              Condition       =>
3230                Make_Op_Not (Loc, Right_Opnd => Condition),
3231              Reason => CE_Partition_Check_Failed));
3232       end Insert_Partition_Check;
3233
3234    --  Start of processing for Build_Subprogram_Calling_Stubs
3235
3236    begin
3237       Target_Partition :=
3238         Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
3239
3240       Subp_Spec := Copy_Specification (Loc,
3241         Spec     => Specification (Vis_Decl),
3242         New_Name => New_Name);
3243
3244       if Locator = Empty then
3245          RCI_Locator := RCI_Cache;
3246          Spec_To_Use := Specification (Vis_Decl);
3247       else
3248          RCI_Locator := Locator;
3249          Spec_To_Use := Subp_Spec;
3250       end if;
3251
3252       --  Find a controlling argument if we have a stub type. Also check
3253       --  if this subprogram can be made asynchronous.
3254
3255       if Stub_Type /= Empty
3256          and then Present (Parameter_Specifications (Spec_To_Use))
3257       then
3258          declare
3259             Current_Parameter : Node_Id :=
3260                                   First (Parameter_Specifications
3261                                            (Spec_To_Use));
3262          begin
3263             while Current_Parameter /= Empty loop
3264
3265                if
3266                  Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type)
3267                then
3268                   if Controlling_Parameter = Empty then
3269                      Controlling_Parameter :=
3270                        Defining_Identifier (Current_Parameter);
3271                   else
3272                      Insert_Partition_Check (Current_Parameter);
3273                   end if;
3274                end if;
3275
3276                Next (Current_Parameter);
3277             end loop;
3278          end;
3279       end if;
3280
3281       if Stub_Type /= Empty then
3282          pragma Assert (Controlling_Parameter /= Empty);
3283
3284          Append_To (Decls,
3285            Make_Object_Declaration (Loc,
3286              Defining_Identifier => Target_Partition,
3287              Constant_Present    => True,
3288              Object_Definition   =>
3289                New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
3290
3291              Expression          =>
3292                Make_Selected_Component (Loc,
3293                  Prefix        =>
3294                    New_Occurrence_Of (Controlling_Parameter, Loc),
3295                  Selector_Name =>
3296                    Make_Identifier (Loc, Name_Origin))));
3297
3298          RPC_Receiver :=
3299            Make_Selected_Component (Loc,
3300              Prefix        =>
3301                New_Occurrence_Of (Controlling_Parameter, Loc),
3302              Selector_Name =>
3303                Make_Identifier (Loc, Name_Receiver));
3304
3305       else
3306          Append_To (Decls,
3307            Make_Object_Declaration (Loc,
3308              Defining_Identifier => Target_Partition,
3309              Constant_Present    => True,
3310              Object_Definition   =>
3311                New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
3312
3313              Expression          =>
3314                Make_Function_Call (Loc,
3315                  Name => Make_Selected_Component (Loc,
3316                    Prefix        =>
3317                      Make_Identifier (Loc, Chars (RCI_Locator)),
3318                    Selector_Name =>
3319                      Make_Identifier (Loc, Name_Get_Active_Partition_ID)))));
3320
3321          RPC_Receiver :=
3322            Make_Selected_Component (Loc,
3323              Prefix        =>
3324                Make_Identifier (Loc, Chars (RCI_Locator)),
3325              Selector_Name =>
3326                Make_Identifier (Loc, Name_Get_RCI_Package_Receiver));
3327       end if;
3328
3329       if Dynamically_Asynchronous then
3330          Asynchronous_Expr :=
3331            Make_Selected_Component (Loc,
3332              Prefix        =>
3333                New_Occurrence_Of (Controlling_Parameter, Loc),
3334              Selector_Name =>
3335                Make_Identifier (Loc, Name_Asynchronous));
3336       end if;
3337
3338       Build_General_Calling_Stubs
3339         (Decls                 => Decls,
3340          Statements            => Statements,
3341          Target_Partition      => Target_Partition,
3342          RPC_Receiver          => RPC_Receiver,
3343          Subprogram_Id         => Make_Integer_Literal (Loc, Subp_Id),
3344          Asynchronous          => Asynchronous_Expr,
3345          Is_Known_Asynchronous => Asynchronous
3346                                     and then not Dynamically_Asynchronous,
3347          Is_Known_Non_Asynchronous
3348                                => not Asynchronous
3349                                     and then not Dynamically_Asynchronous,
3350          Is_Function           => Nkind (Spec_To_Use) =
3351                                     N_Function_Specification,
3352          Spec                  => Spec_To_Use,
3353          Stub_Type             => Stub_Type,
3354          RACW_Type             => RACW_Type,
3355          Nod                   => Vis_Decl);
3356
3357       RCI_Calling_Stubs_Table.Set
3358         (Defining_Unit_Name (Specification (Vis_Decl)),
3359          Defining_Unit_Name (Spec_To_Use));
3360
3361       return
3362         Make_Subprogram_Body (Loc,
3363           Specification              => Subp_Spec,
3364           Declarations               => Decls,
3365           Handled_Statement_Sequence =>
3366             Make_Handled_Sequence_Of_Statements (Loc, Statements));
3367    end Build_Subprogram_Calling_Stubs;
3368
3369    -------------------------
3370    -- Build_Subprogram_Id --
3371    -------------------------
3372
3373    function Build_Subprogram_Id
3374      (Loc : Source_Ptr;
3375       E   : Entity_Id) return Node_Id
3376    is
3377    begin
3378       return Make_Integer_Literal (Loc, Get_Subprogram_Id (E));
3379    end Build_Subprogram_Id;
3380
3381    --------------------------------------
3382    -- Build_Subprogram_Receiving_Stubs --
3383    --------------------------------------
3384
3385    function Build_Subprogram_Receiving_Stubs
3386      (Vis_Decl                 : Node_Id;
3387       Asynchronous             : Boolean;
3388       Dynamically_Asynchronous : Boolean   := False;
3389       Stub_Type                : Entity_Id := Empty;
3390       RACW_Type                : Entity_Id := Empty;
3391       Parent_Primitive         : Entity_Id := Empty) return Node_Id
3392    is
3393       Loc : constant Source_Ptr := Sloc (Vis_Decl);
3394
3395       Stream_Parameter : Node_Id;
3396       Result_Parameter : Node_Id;
3397       --  See explanations of those in Build_Subprogram_Calling_Stubs
3398
3399       Decls : constant List_Id := New_List;
3400       --  All the parameters will get declared before calling the real
3401       --  subprograms. Also the out parameters will be declared.
3402
3403       Statements : constant List_Id := New_List;
3404
3405       Extra_Formal_Statements : constant List_Id := New_List;
3406       --  Statements concerning extra formal parameters
3407
3408       After_Statements : constant List_Id := New_List;
3409       --  Statements to be executed after the subprogram call
3410
3411       Inner_Decls : List_Id := No_List;
3412       --  In case of a function, the inner declarations are needed since
3413       --  the result may be unconstrained.
3414
3415       Excep_Handler : Node_Id;
3416       Excep_Choice  : Entity_Id;
3417       Excep_Code    : List_Id;
3418
3419       Parameter_List : constant List_Id := New_List;
3420       --  List of parameters to be passed to the subprogram
3421
3422       Current_Parameter : Node_Id;
3423
3424       Ordered_Parameters_List : constant List_Id :=
3425                                   Build_Ordered_Parameters_List
3426                                     (Specification (Vis_Decl));
3427
3428       Subp_Spec : Node_Id;
3429       --  Subprogram specification
3430
3431       Called_Subprogram : Node_Id;
3432       --  The subprogram to call
3433
3434       Null_Raise_Statement : Node_Id;
3435
3436       Dynamic_Async : Entity_Id;
3437
3438    begin
3439       if RACW_Type /= Empty then
3440          Called_Subprogram :=
3441            New_Occurrence_Of (Parent_Primitive, Loc);
3442       else
3443          Called_Subprogram :=
3444            New_Occurrence_Of (
3445              Defining_Unit_Name (Specification (Vis_Decl)), Loc);
3446       end if;
3447
3448       Stream_Parameter :=
3449         Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
3450
3451       if Dynamically_Asynchronous then
3452          Dynamic_Async :=
3453            Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
3454       else
3455          Dynamic_Async := Empty;
3456       end if;
3457
3458       if not Asynchronous or else Dynamically_Asynchronous then
3459          Result_Parameter :=
3460            Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
3461
3462          --  The first statement after the subprogram call is a statement to
3463          --  writes a Null_Occurrence into the result stream.
3464
3465          Null_Raise_Statement :=
3466            Make_Attribute_Reference (Loc,
3467              Prefix         =>
3468                New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc),
3469              Attribute_Name => Name_Write,
3470              Expressions    => New_List (
3471                New_Occurrence_Of (Result_Parameter, Loc),
3472                New_Occurrence_Of (RTE (RE_Null_Occurrence), Loc)));
3473
3474          if Dynamically_Asynchronous then
3475             Null_Raise_Statement :=
3476               Make_Implicit_If_Statement (Vis_Decl,
3477                 Condition       =>
3478                   Make_Op_Not (Loc, New_Occurrence_Of (Dynamic_Async, Loc)),
3479                 Then_Statements => New_List (Null_Raise_Statement));
3480          end if;
3481
3482          Append_To (After_Statements, Null_Raise_Statement);
3483
3484       else
3485          Result_Parameter := Empty;
3486       end if;
3487
3488       --  Loop through every parameter and get its value from the stream. If
3489       --  the parameter is unconstrained, then the parameter is read using
3490       --  'Input at the point of declaration.
3491
3492       Current_Parameter := First (Ordered_Parameters_List);
3493
3494       while Current_Parameter /= Empty loop
3495
3496          declare
3497             Etyp        : Entity_Id;
3498             RACW_Controlling : Boolean;
3499             Constrained : Boolean;
3500             Object      : Entity_Id;
3501             Expr        : Node_Id := Empty;
3502
3503          begin
3504             Object := Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
3505             Set_Ekind (Object, E_Variable);
3506
3507             RACW_Controlling :=
3508               Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type);
3509
3510             if RACW_Controlling then
3511
3512                --  We have a controlling formal parameter. Read its address
3513                --  rather than a real object. The address is in Unsigned_64
3514                --  form.
3515
3516                Etyp := RTE (RE_Unsigned_64);
3517             else
3518                Etyp := Etype (Parameter_Type (Current_Parameter));
3519             end if;
3520
3521             Constrained :=
3522               Is_Constrained (Etyp) or else Is_Elementary_Type (Etyp);
3523
3524             if In_Present (Current_Parameter)
3525               or else not Out_Present (Current_Parameter)
3526               or else not Constrained
3527               or else RACW_Controlling
3528             then
3529                --  If an input parameter is contrained, then its reading is
3530                --  deferred until the beginning of the subprogram body. If
3531                --  it is unconstrained, then an expression is built for
3532                --  the object declaration and the variable is set using
3533                --  'Input instead of 'Read.
3534
3535                if Constrained and then not RACW_Controlling then
3536                   Append_To (Statements,
3537                     Make_Attribute_Reference (Loc,
3538                       Prefix         => New_Occurrence_Of (Etyp, Loc),
3539                       Attribute_Name => Name_Read,
3540                       Expressions    => New_List (
3541                         New_Occurrence_Of (Stream_Parameter, Loc),
3542                         New_Occurrence_Of (Object, Loc))));
3543
3544                else
3545                   Expr := Input_With_Tag_Check (Loc,
3546                     Var_Type => Etyp,
3547                     Stream   => Stream_Parameter);
3548                   Append_To (Decls, Expr);
3549                   Expr := Make_Function_Call (Loc,
3550                     New_Occurrence_Of (Defining_Unit_Name
3551                       (Specification (Expr)), Loc));
3552                end if;
3553             end if;
3554
3555             --  If we do not have to output the current parameter, then
3556             --  it can well be flagged as constant. This may allow further
3557             --  optimizations done by the back end.
3558
3559             Append_To (Decls,
3560               Make_Object_Declaration (Loc,
3561                 Defining_Identifier => Object,
3562                 Constant_Present    =>
3563                   not Constrained and then not Out_Present (Current_Parameter),
3564                 Object_Definition   =>
3565                   New_Occurrence_Of (Etyp, Loc),
3566                 Expression          => Expr));
3567
3568             --  An out parameter may be written back using a 'Write
3569             --  attribute instead of a 'Output because it has been
3570             --  constrained by the parameter given to the caller. Note that
3571             --  out controlling arguments in the case of a RACW are not put
3572             --  back in the stream because the pointer on them has not
3573             --  changed.
3574
3575             if Out_Present (Current_Parameter)
3576               and then
3577                 Etype (Parameter_Type (Current_Parameter)) /= Stub_Type
3578             then
3579                Append_To (After_Statements,
3580                  Make_Attribute_Reference (Loc,
3581                    Prefix         => New_Occurrence_Of (Etyp, Loc),
3582                    Attribute_Name => Name_Write,
3583                    Expressions    => New_List (
3584                        New_Occurrence_Of (Result_Parameter, Loc),
3585                      New_Occurrence_Of (Object, Loc))));
3586             end if;
3587
3588             if
3589               Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type)
3590             then
3591                if Nkind (Parameter_Type (Current_Parameter)) /=
3592                  N_Access_Definition
3593                then
3594                   Append_To (Parameter_List,
3595                     Make_Parameter_Association (Loc,
3596                       Selector_Name             =>
3597                         New_Occurrence_Of (
3598                           Defining_Identifier (Current_Parameter), Loc),
3599                       Explicit_Actual_Parameter =>
3600                         Make_Explicit_Dereference (Loc,
3601                           Unchecked_Convert_To (RACW_Type,
3602                             OK_Convert_To (RTE (RE_Address),
3603                               New_Occurrence_Of (Object, Loc))))));
3604
3605                else
3606                   Append_To (Parameter_List,
3607                     Make_Parameter_Association (Loc,
3608                       Selector_Name             =>
3609                         New_Occurrence_Of (
3610                           Defining_Identifier (Current_Parameter), Loc),
3611                       Explicit_Actual_Parameter =>
3612                         Unchecked_Convert_To (RACW_Type,
3613                           OK_Convert_To (RTE (RE_Address),
3614                             New_Occurrence_Of (Object, Loc)))));
3615                end if;
3616
3617             else
3618                Append_To (Parameter_List,
3619                  Make_Parameter_Association (Loc,
3620                    Selector_Name             =>
3621                      New_Occurrence_Of (
3622                        Defining_Identifier (Current_Parameter), Loc),
3623                    Explicit_Actual_Parameter =>
3624                      New_Occurrence_Of (Object, Loc)));
3625             end if;
3626
3627             --  If the current parameter needs an extra formal, then read it
3628             --  from the stream and set the corresponding semantic field in
3629             --  the variable. If the kind of the parameter identifier is
3630             --  E_Void, then this is a compiler generated parameter that
3631             --  doesn't need an extra constrained status.
3632
3633             --  The case of Extra_Accessibility should also be handled ???
3634
3635             if Nkind (Parameter_Type (Current_Parameter)) /=
3636                                                       N_Access_Definition
3637               and then
3638                 Ekind (Defining_Identifier (Current_Parameter)) /= E_Void
3639               and then
3640                 Present (Extra_Constrained
3641                   (Defining_Identifier (Current_Parameter)))
3642             then
3643                declare
3644                   Extra_Parameter : constant Entity_Id :=
3645                                       Extra_Constrained
3646                                         (Defining_Identifier
3647                                           (Current_Parameter));
3648
3649                   Formal_Entity : constant Entity_Id :=
3650                                     Make_Defining_Identifier
3651                                         (Loc, Chars (Extra_Parameter));
3652
3653                   Formal_Type : constant Entity_Id :=
3654                                   Etype (Extra_Parameter);
3655
3656                begin
3657                   Append_To (Decls,
3658                     Make_Object_Declaration (Loc,
3659                       Defining_Identifier => Formal_Entity,
3660                       Object_Definition   =>
3661                         New_Occurrence_Of (Formal_Type, Loc)));
3662
3663                   Append_To (Extra_Formal_Statements,
3664                     Make_Attribute_Reference (Loc,
3665                       Prefix         => New_Occurrence_Of (Formal_Type, Loc),
3666                       Attribute_Name => Name_Read,
3667                       Expressions    => New_List (
3668                         New_Occurrence_Of (Stream_Parameter, Loc),
3669                         New_Occurrence_Of (Formal_Entity, Loc))));
3670                   Set_Extra_Constrained (Object, Formal_Entity);
3671                end;
3672             end if;
3673          end;
3674
3675          Next (Current_Parameter);
3676       end loop;
3677
3678       --  Append the formal statements list at the end of regular statements
3679
3680       Append_List_To (Statements, Extra_Formal_Statements);
3681
3682       if Nkind (Specification (Vis_Decl)) = N_Function_Specification then
3683
3684          --  The remote subprogram is a function. We build an inner block to
3685          --  be able to hold a potentially unconstrained result in a variable.
3686
3687          declare
3688             Etyp   : constant Entity_Id :=
3689                        Etype (Subtype_Mark (Specification (Vis_Decl)));
3690             Result : constant Node_Id   :=
3691                        Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
3692
3693          begin
3694             Inner_Decls := New_List (
3695               Make_Object_Declaration (Loc,
3696                 Defining_Identifier => Result,
3697                 Constant_Present    => True,
3698                 Object_Definition   => New_Occurrence_Of (Etyp, Loc),
3699                 Expression          =>
3700                   Make_Function_Call (Loc,
3701                     Name                   => Called_Subprogram,
3702                     Parameter_Associations => Parameter_List)));
3703
3704             Append_To (After_Statements,
3705               Make_Attribute_Reference (Loc,
3706                 Prefix         => New_Occurrence_Of (Etyp, Loc),
3707                 Attribute_Name => Name_Output,
3708                 Expressions    => New_List (
3709                   New_Occurrence_Of (Result_Parameter, Loc),
3710                   New_Occurrence_Of (Result, Loc))));
3711          end;
3712
3713          Append_To (Statements,
3714            Make_Block_Statement (Loc,
3715              Declarations               => Inner_Decls,
3716              Handled_Statement_Sequence =>
3717                Make_Handled_Sequence_Of_Statements (Loc,
3718                  Statements => After_Statements)));
3719
3720       else
3721          --  The remote subprogram is a procedure. We do not need any inner
3722          --  block in this case.
3723
3724          if Dynamically_Asynchronous then
3725             Append_To (Decls,
3726               Make_Object_Declaration (Loc,
3727                 Defining_Identifier => Dynamic_Async,
3728                 Object_Definition   =>
3729                   New_Occurrence_Of (Standard_Boolean, Loc)));
3730
3731             Append_To (Statements,
3732               Make_Attribute_Reference (Loc,
3733                 Prefix         => New_Occurrence_Of (Standard_Boolean, Loc),
3734                 Attribute_Name => Name_Read,
3735                 Expressions    => New_List (
3736                   New_Occurrence_Of (Stream_Parameter, Loc),
3737                   New_Occurrence_Of (Dynamic_Async, Loc))));
3738          end if;
3739
3740          Append_To (Statements,
3741            Make_Procedure_Call_Statement (Loc,
3742              Name                   => Called_Subprogram,
3743              Parameter_Associations => Parameter_List));
3744
3745          Append_List_To (Statements, After_Statements);
3746       end if;
3747
3748       if Asynchronous and then not Dynamically_Asynchronous then
3749
3750          --  An asynchronous procedure does not want a Result
3751          --  parameter. Also, we put an exception handler with an others
3752          --  clause that does nothing.
3753
3754          Subp_Spec :=
3755            Make_Procedure_Specification (Loc,
3756              Defining_Unit_Name       =>
3757                Make_Defining_Identifier (Loc, New_Internal_Name ('F')),
3758              Parameter_Specifications => New_List (
3759                Make_Parameter_Specification (Loc,
3760                  Defining_Identifier => Stream_Parameter,
3761                  Parameter_Type      =>
3762                    Make_Access_Definition (Loc,
3763                    Subtype_Mark =>
3764                      New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc)))));
3765
3766          Excep_Handler :=
3767            Make_Exception_Handler (Loc,
3768              Exception_Choices =>
3769                New_List (Make_Others_Choice (Loc)),
3770              Statements        => New_List (
3771                Make_Null_Statement (Loc)));
3772
3773       else
3774          --  In the other cases, if an exception is raised, then the
3775          --  exception occurrence is copied into the output stream and
3776          --  no other output parameter is written.
3777
3778          Excep_Choice :=
3779            Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
3780
3781          Excep_Code := New_List (
3782            Make_Attribute_Reference (Loc,
3783              Prefix         =>
3784                New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc),
3785              Attribute_Name => Name_Write,
3786              Expressions    => New_List (
3787                New_Occurrence_Of (Result_Parameter, Loc),
3788                New_Occurrence_Of (Excep_Choice, Loc))));
3789
3790          if Dynamically_Asynchronous then
3791             Excep_Code := New_List (
3792               Make_Implicit_If_Statement (Vis_Decl,
3793                 Condition       => Make_Op_Not (Loc,
3794                   New_Occurrence_Of (Dynamic_Async, Loc)),
3795                 Then_Statements => Excep_Code));
3796          end if;
3797
3798          Excep_Handler :=
3799            Make_Exception_Handler (Loc,
3800              Choice_Parameter   => Excep_Choice,
3801              Exception_Choices  => New_List (Make_Others_Choice (Loc)),
3802              Statements         => Excep_Code);
3803
3804          Subp_Spec :=
3805            Make_Procedure_Specification (Loc,
3806              Defining_Unit_Name       =>
3807                Make_Defining_Identifier (Loc, New_Internal_Name ('F')),
3808
3809              Parameter_Specifications => New_List (
3810                Make_Parameter_Specification (Loc,
3811                  Defining_Identifier => Stream_Parameter,
3812                  Parameter_Type      =>
3813                    Make_Access_Definition (Loc,
3814                    Subtype_Mark =>
3815                      New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc))),
3816
3817                Make_Parameter_Specification (Loc,
3818                  Defining_Identifier => Result_Parameter,
3819                  Parameter_Type      =>
3820                    Make_Access_Definition (Loc,
3821                   Subtype_Mark =>
3822                   New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc)))));
3823       end if;
3824
3825       return
3826         Make_Subprogram_Body (Loc,
3827           Specification              => Subp_Spec,
3828           Declarations               => Decls,
3829           Handled_Statement_Sequence =>
3830             Make_Handled_Sequence_Of_Statements (Loc,
3831               Statements         => Statements,
3832               Exception_Handlers => New_List (Excep_Handler)));
3833    end Build_Subprogram_Receiving_Stubs;
3834
3835    ------------------------
3836    -- Copy_Specification --
3837    ------------------------
3838
3839    function Copy_Specification
3840      (Loc         : Source_Ptr;
3841       Spec        : Node_Id;
3842       Object_Type : Entity_Id := Empty;
3843       Stub_Type   : Entity_Id := Empty;
3844       New_Name    : Name_Id   := No_Name) return Node_Id
3845    is
3846       Parameters : List_Id := No_List;
3847
3848       Current_Parameter  : Node_Id;
3849       Current_Identifier : Entity_Id;
3850       Current_Type       : Node_Id;
3851       Current_Etype      : Entity_Id;
3852
3853       Name_For_New_Spec : Name_Id;
3854
3855       New_Identifier : Entity_Id;
3856
3857    begin
3858       if New_Name = No_Name then
3859          pragma Assert (Nkind (Spec) = N_Function_Specification
3860                 or else Nkind (Spec) = N_Procedure_Specification);
3861
3862          Name_For_New_Spec := Chars (Defining_Unit_Name (Spec));
3863       else
3864          Name_For_New_Spec := New_Name;
3865       end if;
3866
3867       if Present (Parameter_Specifications (Spec)) then
3868          Parameters        := New_List;
3869          Current_Parameter := First (Parameter_Specifications (Spec));
3870          while Current_Parameter /= Empty loop
3871             Current_Identifier := Defining_Identifier (Current_Parameter);
3872             Current_Type       := Parameter_Type (Current_Parameter);
3873
3874             if Nkind (Current_Type) = N_Access_Definition then
3875                Current_Etype := Entity (Subtype_Mark (Current_Type));
3876
3877                if Present (Object_Type) then
3878                   pragma Assert (
3879                     Root_Type (Current_Etype) = Root_Type (Object_Type));
3880                   Current_Type :=
3881                     Make_Access_Definition (Loc,
3882                       Subtype_Mark => New_Occurrence_Of (Stub_Type, Loc));
3883                else
3884                   Current_Type :=
3885                     Make_Access_Definition (Loc,
3886                       Subtype_Mark =>
3887                         New_Occurrence_Of (Current_Etype, Loc));
3888                end if;
3889
3890             else
3891                Current_Etype := Entity (Current_Type);
3892
3893                if Object_Type /= Empty
3894                  and then Current_Etype = Object_Type
3895                then
3896                   Current_Type := New_Occurrence_Of (Stub_Type, Loc);
3897                else
3898                   Current_Type := New_Occurrence_Of (Current_Etype, Loc);
3899                end if;
3900             end if;
3901
3902             New_Identifier := Make_Defining_Identifier (Loc,
3903               Chars (Current_Identifier));
3904
3905             Append_To (Parameters,
3906               Make_Parameter_Specification (Loc,
3907                 Defining_Identifier => New_Identifier,
3908                 Parameter_Type      => Current_Type,
3909                 In_Present          => In_Present (Current_Parameter),
3910                 Out_Present         => Out_Present (Current_Parameter),
3911                 Expression          =>
3912                   New_Copy_Tree (Expression (Current_Parameter))));
3913
3914             Next (Current_Parameter);
3915          end loop;
3916       end if;
3917
3918       case Nkind (Spec) is
3919
3920          when N_Function_Specification | N_Access_Function_Definition =>
3921             return
3922               Make_Function_Specification (Loc,
3923                 Defining_Unit_Name       =>
3924                   Make_Defining_Identifier (Loc,
3925                     Chars => Name_For_New_Spec),
3926                 Parameter_Specifications => Parameters,
3927                 Subtype_Mark             =>
3928                   New_Occurrence_Of (Entity (Subtype_Mark (Spec)), Loc));
3929
3930          when N_Procedure_Specification | N_Access_Procedure_Definition =>
3931             return
3932               Make_Procedure_Specification (Loc,
3933                 Defining_Unit_Name       =>
3934                   Make_Defining_Identifier (Loc,
3935                     Chars => Name_For_New_Spec),
3936                 Parameter_Specifications => Parameters);
3937
3938          when others =>
3939             raise Program_Error;
3940       end case;
3941    end Copy_Specification;
3942
3943    ---------------------------
3944    -- Could_Be_Asynchronous --
3945    ---------------------------
3946
3947    function Could_Be_Asynchronous (Spec : Node_Id) return Boolean is
3948       Current_Parameter : Node_Id;
3949
3950    begin
3951       if Present (Parameter_Specifications (Spec)) then
3952          Current_Parameter := First (Parameter_Specifications (Spec));
3953          while Current_Parameter /= Empty loop
3954             if Out_Present (Current_Parameter) then
3955                return False;
3956             end if;
3957
3958             Next (Current_Parameter);
3959          end loop;
3960       end if;
3961
3962       return True;
3963    end Could_Be_Asynchronous;
3964
3965    ---------------------------------------------
3966    -- Expand_All_Calls_Remote_Subprogram_Call --
3967    ---------------------------------------------
3968
3969    procedure Expand_All_Calls_Remote_Subprogram_Call (N : Node_Id) is
3970       Called_Subprogram : constant Entity_Id  := Entity (Name (N));
3971       RCI_Package       : constant Entity_Id  := Scope (Called_Subprogram);
3972       Loc               : constant Source_Ptr := Sloc (N);
3973       RCI_Locator       : Node_Id;
3974       RCI_Cache         : Entity_Id;
3975       Calling_Stubs     : Node_Id;
3976       E_Calling_Stubs   : Entity_Id;
3977
3978    begin
3979       E_Calling_Stubs := RCI_Calling_Stubs_Table.Get (Called_Subprogram);
3980
3981       if E_Calling_Stubs = Empty then
3982          RCI_Cache := RCI_Locator_Table.Get (RCI_Package);
3983
3984          if RCI_Cache = Empty then
3985             RCI_Locator :=
3986               RCI_Package_Locator
3987                 (Loc, Specification (Unit_Declaration_Node (RCI_Package)));
3988             Prepend_To (Current_Sem_Unit_Declarations, RCI_Locator);
3989
3990             --  The RCI_Locator package is inserted at the top level in the
3991             --  current unit, and must appear in the proper scope, so that it
3992             --  is not prematurely removed by the GCC back-end.
3993
3994             declare
3995                Scop : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
3996
3997             begin
3998                if Ekind (Scop) = E_Package_Body then
3999                   New_Scope (Spec_Entity (Scop));
4000
4001                elsif Ekind (Scop) = E_Subprogram_Body then
4002                   New_Scope
4003                      (Corresponding_Spec (Unit_Declaration_Node (Scop)));
4004
4005                else
4006                   New_Scope (Scop);
4007                end if;
4008
4009                Analyze (RCI_Locator);
4010                Pop_Scope;
4011             end;
4012
4013             RCI_Cache   := Defining_Unit_Name (RCI_Locator);
4014
4015          else
4016             RCI_Locator := Parent (RCI_Cache);
4017          end if;
4018
4019          Calling_Stubs := Build_Subprogram_Calling_Stubs
4020            (Vis_Decl               => Parent (Parent (Called_Subprogram)),
4021             Subp_Id                => Get_Subprogram_Id (Called_Subprogram),
4022             Asynchronous           => Nkind (N) = N_Procedure_Call_Statement
4023                                         and then
4024                                       Is_Asynchronous (Called_Subprogram),
4025             Locator                => RCI_Cache,
4026             New_Name               => New_Internal_Name ('S'));
4027          Insert_After (RCI_Locator, Calling_Stubs);
4028          Analyze (Calling_Stubs);
4029          E_Calling_Stubs := Defining_Unit_Name (Specification (Calling_Stubs));
4030       end if;
4031
4032       Rewrite (Name (N), New_Occurrence_Of (E_Calling_Stubs, Loc));
4033    end Expand_All_Calls_Remote_Subprogram_Call;
4034
4035    ---------------------------------
4036    -- Expand_Calling_Stubs_Bodies --
4037    ---------------------------------
4038
4039    procedure Expand_Calling_Stubs_Bodies (Unit_Node : Node_Id) is
4040       Spec  : constant Node_Id := Specification (Unit_Node);
4041       Decls : constant List_Id := Visible_Declarations (Spec);
4042
4043    begin
4044       New_Scope (Scope_Of_Spec (Spec));
4045       Add_Calling_Stubs_To_Declarations (Specification (Unit_Node),
4046                                          Decls);
4047       Pop_Scope;
4048    end Expand_Calling_Stubs_Bodies;
4049
4050    -----------------------------------
4051    -- Expand_Receiving_Stubs_Bodies --
4052    -----------------------------------
4053
4054    procedure Expand_Receiving_Stubs_Bodies (Unit_Node : Node_Id) is
4055       Spec  : Node_Id;
4056       Decls : List_Id;
4057       Temp  : List_Id;
4058
4059    begin
4060       if Nkind (Unit_Node) = N_Package_Declaration then
4061          Spec  := Specification (Unit_Node);
4062          Decls := Visible_Declarations (Spec);
4063          New_Scope (Scope_Of_Spec (Spec));
4064          Add_Receiving_Stubs_To_Declarations (Spec, Decls);
4065
4066       else
4067          Spec  :=
4068            Package_Specification_Of_Scope (Corresponding_Spec (Unit_Node));
4069          Decls := Declarations (Unit_Node);
4070          New_Scope (Scope_Of_Spec (Unit_Node));
4071          Temp := New_List;
4072          Add_Receiving_Stubs_To_Declarations (Spec, Temp);
4073          Insert_List_Before (First (Decls), Temp);
4074       end if;
4075
4076       Pop_Scope;
4077    end Expand_Receiving_Stubs_Bodies;
4078
4079    -------------------------
4080    -- Get_Pkg_Name_string --
4081    -------------------------
4082
4083    procedure Get_Pkg_Name_String (Decl_Node : Node_Id) is
4084       Unit_Name_Id : constant Unit_Name_Type := Get_Unit_Name (Decl_Node);
4085
4086    begin
4087       Get_Unit_Name_String (Unit_Name_Id);
4088
4089       --  Remove seven last character (" (spec)" or " (body)").
4090
4091       Name_Len := Name_Len - 7;
4092       pragma Assert (Name_Buffer (Name_Len + 1) = ' ');
4093    end Get_Pkg_Name_String;
4094
4095    -----------------------
4096    -- Get_Subprogram_Id --
4097    -----------------------
4098
4099    function Get_Subprogram_Id (E : Entity_Id) return Int is
4100       Current_Declaration : Node_Id;
4101       Result              : Int := First_RCI_Subprogram_Id;
4102
4103    begin
4104       pragma Assert
4105         (Is_Remote_Call_Interface (Scope (E))
4106            and then
4107              (Nkind (Parent (E)) = N_Procedure_Specification
4108                 or else
4109               Nkind (Parent (E)) = N_Function_Specification));
4110
4111       Current_Declaration :=
4112         First (Visible_Declarations
4113           (Package_Specification_Of_Scope (Scope (E))));
4114
4115       while Current_Declaration /= Empty loop
4116          if Nkind (Current_Declaration) = N_Subprogram_Declaration
4117            and then Comes_From_Source (Current_Declaration)
4118          then
4119             if Defining_Unit_Name
4120                  (Specification (Current_Declaration)) = E
4121             then
4122                return Result;
4123             end if;
4124
4125             Result := Result + 1;
4126          end if;
4127
4128          Next (Current_Declaration);
4129       end loop;
4130
4131       --  Error if we do not find it
4132
4133       raise Program_Error;
4134    end Get_Subprogram_Id;
4135
4136    ----------
4137    -- Hash --
4138    ----------
4139
4140    function Hash (F : Entity_Id) return Hash_Index is
4141    begin
4142       return Hash_Index (Natural (F) mod Positive (Hash_Index'Last + 1));
4143    end Hash;
4144
4145    --------------------------
4146    -- Input_With_Tag_Check --
4147    --------------------------
4148
4149    function Input_With_Tag_Check
4150      (Loc      : Source_Ptr;
4151       Var_Type : Entity_Id;
4152       Stream   : Entity_Id)
4153       return     Node_Id
4154    is
4155    begin
4156       return
4157         Make_Subprogram_Body (Loc,
4158           Specification              => Make_Function_Specification (Loc,
4159             Defining_Unit_Name =>
4160               Make_Defining_Identifier (Loc, New_Internal_Name ('S')),
4161             Subtype_Mark       => New_Occurrence_Of (Var_Type, Loc)),
4162           Declarations               => No_List,
4163           Handled_Statement_Sequence =>
4164             Make_Handled_Sequence_Of_Statements (Loc, New_List (
4165               Make_Tag_Check (Loc,
4166                 Make_Return_Statement (Loc,
4167                   Make_Attribute_Reference (Loc,
4168                     Prefix         => New_Occurrence_Of (Var_Type, Loc),
4169                     Attribute_Name => Name_Input,
4170                     Expressions    =>
4171                       New_List (New_Occurrence_Of (Stream, Loc))))))));
4172    end Input_With_Tag_Check;
4173
4174    --------------------------------
4175    -- Is_RACW_Controlling_Formal --
4176    --------------------------------
4177
4178    function Is_RACW_Controlling_Formal
4179      (Parameter : Node_Id;
4180       Stub_Type : Entity_Id)
4181       return      Boolean
4182    is
4183       Typ : Entity_Id;
4184
4185    begin
4186       --  If the kind of the parameter is E_Void, then it is not a
4187       --  controlling formal (this can happen in the context of RAS).
4188
4189       if Ekind (Defining_Identifier (Parameter)) = E_Void then
4190          return False;
4191       end if;
4192
4193       --  If the parameter is not a controlling formal, then it cannot
4194       --  be possibly a RACW_Controlling_Formal.
4195
4196       if not Is_Controlling_Formal (Defining_Identifier (Parameter)) then
4197          return False;
4198       end if;
4199
4200       Typ := Parameter_Type (Parameter);
4201       return (Nkind (Typ) = N_Access_Definition
4202                and then Etype (Subtype_Mark (Typ)) = Stub_Type)
4203         or else Etype (Typ) = Stub_Type;
4204    end Is_RACW_Controlling_Formal;
4205
4206    --------------------
4207    -- Make_Tag_Check --
4208    --------------------
4209
4210    function Make_Tag_Check (Loc : Source_Ptr; N : Node_Id) return Node_Id is
4211       Occ : constant Entity_Id :=
4212               Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
4213
4214    begin
4215       return Make_Block_Statement (Loc,
4216         Handled_Statement_Sequence =>
4217           Make_Handled_Sequence_Of_Statements (Loc,
4218             Statements         => New_List (N),
4219
4220             Exception_Handlers => New_List (
4221               Make_Exception_Handler (Loc,
4222                 Choice_Parameter => Occ,
4223
4224                 Exception_Choices =>
4225                   New_List (New_Occurrence_Of (RTE (RE_Tag_Error), Loc)),
4226
4227                 Statements =>
4228                   New_List (Make_Procedure_Call_Statement (Loc,
4229                     New_Occurrence_Of
4230                       (RTE (RE_Raise_Program_Error_Unknown_Tag), Loc),
4231                     New_List (New_Occurrence_Of (Occ, Loc))))))));
4232    end Make_Tag_Check;
4233
4234    ----------------------------
4235    -- Need_Extra_Constrained --
4236    ----------------------------
4237
4238    function Need_Extra_Constrained (Parameter : Node_Id) return Boolean is
4239       Etyp : constant Entity_Id := Etype (Parameter_Type (Parameter));
4240
4241    begin
4242       return Out_Present (Parameter)
4243         and then Has_Discriminants (Etyp)
4244         and then not Is_Constrained (Etyp)
4245         and then not Is_Indefinite_Subtype (Etyp);
4246    end Need_Extra_Constrained;
4247
4248    ------------------------------------
4249    -- Pack_Entity_Into_Stream_Access --
4250    ------------------------------------
4251
4252    function Pack_Entity_Into_Stream_Access
4253      (Loc    : Source_Ptr;
4254       Stream : Node_Id;
4255       Object : Entity_Id;
4256       Etyp   : Entity_Id := Empty) return Node_Id
4257    is
4258       Typ : Entity_Id;
4259
4260    begin
4261       if Etyp /= Empty then
4262          Typ := Etyp;
4263       else
4264          Typ := Etype (Object);
4265       end if;
4266
4267       return
4268         Pack_Node_Into_Stream_Access (Loc,
4269           Stream => Stream,
4270           Object => New_Occurrence_Of (Object, Loc),
4271           Etyp   => Typ);
4272    end Pack_Entity_Into_Stream_Access;
4273
4274    ---------------------------
4275    -- Pack_Node_Into_Stream --
4276    ---------------------------
4277
4278    function Pack_Node_Into_Stream
4279      (Loc    : Source_Ptr;
4280       Stream : Entity_Id;
4281       Object : Node_Id;
4282       Etyp   : Entity_Id) return Node_Id
4283    is
4284       Write_Attribute : Name_Id := Name_Write;
4285
4286    begin
4287       if not Is_Constrained (Etyp) then
4288          Write_Attribute := Name_Output;
4289       end if;
4290
4291       return
4292         Make_Attribute_Reference (Loc,
4293           Prefix         => New_Occurrence_Of (Etyp, Loc),
4294           Attribute_Name => Write_Attribute,
4295           Expressions    => New_List (
4296             Make_Attribute_Reference (Loc,
4297               Prefix         => New_Occurrence_Of (Stream, Loc),
4298               Attribute_Name => Name_Access),
4299             Object));
4300    end Pack_Node_Into_Stream;
4301
4302    ----------------------------------
4303    -- Pack_Node_Into_Stream_Access --
4304    ----------------------------------
4305
4306    function Pack_Node_Into_Stream_Access
4307      (Loc    : Source_Ptr;
4308       Stream : Node_Id;
4309       Object : Node_Id;
4310       Etyp   : Entity_Id) return Node_Id
4311    is
4312       Write_Attribute : Name_Id := Name_Write;
4313
4314    begin
4315       if not Is_Constrained (Etyp) then
4316          Write_Attribute := Name_Output;
4317       end if;
4318
4319       return
4320         Make_Attribute_Reference (Loc,
4321           Prefix         => New_Occurrence_Of (Etyp, Loc),
4322           Attribute_Name => Write_Attribute,
4323           Expressions    => New_List (
4324             Stream,
4325             Object));
4326    end Pack_Node_Into_Stream_Access;
4327
4328    -------------------------------
4329    -- RACW_Type_Is_Asynchronous --
4330    -------------------------------
4331
4332    procedure RACW_Type_Is_Asynchronous (RACW_Type : Entity_Id) is
4333       Asynchronous_Flag : constant Entity_Id :=
4334                            Asynchronous_Flags_Table.Get (RACW_Type);
4335    begin
4336       Replace (Expression (Parent (Asynchronous_Flag)),
4337         New_Occurrence_Of (Standard_True, Sloc (Asynchronous_Flag)));
4338    end RACW_Type_Is_Asynchronous;
4339
4340    -------------------------
4341    -- RCI_Package_Locator --
4342    -------------------------
4343
4344    function RCI_Package_Locator
4345      (Loc          : Source_Ptr;
4346       Package_Spec : Node_Id) return Node_Id
4347    is
4348       Inst : Node_Id;
4349       Pkg_Name : String_Id;
4350
4351    begin
4352       Get_Pkg_Name_String (Package_Spec);
4353       Pkg_Name := String_From_Name_Buffer;
4354       Inst :=
4355         Make_Package_Instantiation (Loc,
4356           Defining_Unit_Name   =>
4357             Make_Defining_Identifier (Loc, New_Internal_Name ('R')),
4358           Name                 =>
4359             New_Occurrence_Of (RTE (RE_RCI_Locator), Loc),
4360           Generic_Associations => New_List (
4361             Make_Generic_Association (Loc,
4362               Selector_Name                     =>
4363                 Make_Identifier (Loc, Name_RCI_Name),
4364               Explicit_Generic_Actual_Parameter =>
4365                 Make_String_Literal (Loc,
4366                   Strval => Pkg_Name))));
4367
4368       RCI_Locator_Table.Set (Defining_Unit_Name (Package_Spec),
4369         Defining_Unit_Name (Inst));
4370       return Inst;
4371    end RCI_Package_Locator;
4372
4373    -----------------------------------------------
4374    -- Remote_Types_Tagged_Full_View_Encountered --
4375    -----------------------------------------------
4376
4377    procedure Remote_Types_Tagged_Full_View_Encountered
4378      (Full_View : Entity_Id)
4379    is
4380       Stub_Elements : constant Stub_Structure :=
4381                         Stubs_Table.Get (Full_View);
4382
4383    begin
4384       if Stub_Elements /= Empty_Stub_Structure then
4385          Add_RACW_Primitive_Declarations_And_Bodies
4386            (Full_View,
4387             Parent (Declaration_Node (Stub_Elements.Object_RPC_Receiver)),
4388             List_Containing (Declaration_Node (Full_View)));
4389       end if;
4390    end Remote_Types_Tagged_Full_View_Encountered;
4391
4392    -------------------
4393    -- Scope_Of_Spec --
4394    -------------------
4395
4396    function Scope_Of_Spec (Spec : Node_Id) return Entity_Id is
4397       Unit_Name : Node_Id := Defining_Unit_Name (Spec);
4398
4399    begin
4400       while Nkind (Unit_Name) /= N_Defining_Identifier loop
4401          Unit_Name := Defining_Identifier (Unit_Name);
4402       end loop;
4403
4404       return Unit_Name;
4405    end Scope_Of_Spec;
4406
4407    --------------------------
4408    -- Underlying_RACW_Type --
4409    --------------------------
4410
4411    function Underlying_RACW_Type (RAS_Typ : Entity_Id) return Entity_Id is
4412       Record_Type : Entity_Id;
4413
4414    begin
4415       if Ekind (RAS_Typ) = E_Record_Type then
4416          Record_Type := RAS_Typ;
4417       else
4418          pragma Assert (Present (Equivalent_Type (RAS_Typ)));
4419          Record_Type := Equivalent_Type (RAS_Typ);
4420       end if;
4421
4422       return
4423         Etype (Subtype_Indication (
4424           Component_Definition (
4425            First (Component_Items (Component_List (
4426             Type_Definition (Declaration_Node (Record_Type))))))));
4427    end Underlying_RACW_Type;
4428
4429 end Exp_Dist;