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