gcc/ada/exp_dist.adb

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