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