gcc/ada/exp_dist.adb

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