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