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