diff options
| author | Dan Albert <danalbert@google.com> | 2016-01-14 16:43:34 -0800 |
|---|---|---|
| committer | Dan Albert <danalbert@google.com> | 2016-01-22 14:51:24 -0800 |
| commit | 3186be22b6598fbd467b126347d1c7f48ccb7f71 (patch) | |
| tree | 2b176d3ce027fa5340160978effeb88ec9054aaa /gcc-4.8.1/gcc/ada/exp_dist.adb | |
| parent | a45222a0e5951558bd896b0513bf638eb376e086 (diff) | |
| download | toolchain_gcc-3186be22b6598fbd467b126347d1c7f48ccb7f71.tar.gz toolchain_gcc-3186be22b6598fbd467b126347d1c7f48ccb7f71.tar.bz2 toolchain_gcc-3186be22b6598fbd467b126347d1c7f48ccb7f71.zip | |
Check in a pristine copy of GCC 4.8.1.
The copy of GCC that we use for Android is still not working for
mingw. Rather than finding all the differences that have crept into
our GCC, just check in a copy from
ftp://ftp.gnu.org/gnu/gcc/gcc-4.9.3/gcc-4.8.1.tar.bz2.
GCC 4.8.1 was chosen because it is what we have been using for mingw
thus far, and the emulator doesn't yet work when upgrading to 4.9.
Bug: http://b/26523949
Change-Id: Iedc0f05243d4332cc27ccd46b8a4b203c88dcaa3
Diffstat (limited to 'gcc-4.8.1/gcc/ada/exp_dist.adb')
| -rw-r--r-- | gcc-4.8.1/gcc/ada/exp_dist.adb | 11555 |
1 files changed, 11555 insertions, 0 deletions
diff --git a/gcc-4.8.1/gcc/ada/exp_dist.adb b/gcc-4.8.1/gcc/ada/exp_dist.adb new file mode 100644 index 000000000..e0e7250a3 --- /dev/null +++ b/gcc-4.8.1/gcc/ada/exp_dist.adb @@ -0,0 +1,11555 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P_ D I S T -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Einfo; use Einfo; +with Elists; use Elists; +with Exp_Atag; use Exp_Atag; +with Exp_Disp; use Exp_Disp; +with Exp_Strm; use Exp_Strm; +with Exp_Tss; use Exp_Tss; +with Exp_Util; use Exp_Util; +with Lib; use Lib; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Opt; use Opt; +with Rtsfind; use Rtsfind; +with Sem; use Sem; +with Sem_Aux; use Sem_Aux; +with Sem_Cat; use Sem_Cat; +with Sem_Ch3; use Sem_Ch3; +with Sem_Ch8; use Sem_Ch8; +with Sem_Ch12; use Sem_Ch12; +with Sem_Dist; use Sem_Dist; +with Sem_Eval; use Sem_Eval; +with Sem_Util; use Sem_Util; +with Sinfo; use Sinfo; +with Stand; use Stand; +with Stringt; use Stringt; +with Tbuild; use Tbuild; +with Ttypes; use Ttypes; +with Uintp; use Uintp; + +with GNAT.HTable; use GNAT.HTable; + +package body Exp_Dist is + + -- The following model has been used to implement distributed objects: + -- given a designated type D and a RACW type R, then a record of the form: + + -- type Stub is tagged record + -- [...declaration similar to s-parint.ads RACW_Stub_Type...] + -- end record; + + -- is built. This type has two properties: + + -- 1) Since it has the same structure as RACW_Stub_Type, it can + -- be converted to and from this type to make it suitable for + -- System.Partition_Interface.Get_Unique_Remote_Pointer in order + -- to avoid memory leaks when the same remote object arrives on the + -- same partition through several paths; + + -- 2) It also has the same dispatching table as the designated type D, + -- and thus can be used as an object designated by a value of type + -- R on any partition other than the one on which the object has + -- been created, since only dispatching calls will be performed and + -- the fields themselves will not be used. We call Derive_Subprograms + -- to fake half a derivation to ensure that the subprograms do have + -- the same dispatching table. + + First_RCI_Subprogram_Id : constant := 2; + -- RCI subprograms are numbered starting at 2. The RCI receiver for + -- an RCI package can thus identify calls received through remote + -- access-to-subprogram dereferences by the fact that they have a + -- (primitive) subprogram id of 0, and 1 is used for the internal RAS + -- information lookup operation. (This is for the Garlic code generation, + -- where subprograms are identified by numbers; in the PolyORB version, + -- they are identified by name, with a numeric suffix for homonyms.) + + type Hash_Index is range 0 .. 50; + + ----------------------- + -- Local subprograms -- + ----------------------- + + function Hash (F : Entity_Id) return Hash_Index; + -- DSA expansion associates stubs to distributed object types using a hash + -- table on entity ids. + + function Hash (F : Name_Id) return Hash_Index; + -- The generation of subprogram identifiers requires an overload counter + -- to be associated with each remote subprogram name. These counters are + -- maintained in a hash table on name ids. + + type Subprogram_Identifiers is record + Str_Identifier : String_Id; + Int_Identifier : Int; + end record; + + package Subprogram_Identifier_Table is + new Simple_HTable (Header_Num => Hash_Index, + Element => Subprogram_Identifiers, + No_Element => (No_String, 0), + Key => Entity_Id, + Hash => Hash, + Equal => "="); + -- Mapping between a remote subprogram and the corresponding subprogram + -- identifiers. + + package Overload_Counter_Table is + new Simple_HTable (Header_Num => Hash_Index, + Element => Int, + No_Element => 0, + Key => Name_Id, + Hash => Hash, + Equal => "="); + -- Mapping between a subprogram name and an integer that counts the number + -- of defining subprogram names with that Name_Id encountered so far in a + -- given context (an interface). + + function Get_Subprogram_Ids (Def : Entity_Id) return Subprogram_Identifiers; + function Get_Subprogram_Id (Def : Entity_Id) return String_Id; + function Get_Subprogram_Id (Def : Entity_Id) return Int; + -- Given a subprogram defined in a RCI package, get its distribution + -- subprogram identifiers (the distribution identifiers are a unique + -- subprogram number, and the non-qualified subprogram name, in the + -- casing used for the subprogram declaration; if the name is overloaded, + -- a double underscore and a serial number are appended. + -- + -- The integer identifier is used to perform remote calls with GARLIC; + -- the string identifier is used in the case of PolyORB. + -- + -- Although the PolyORB DSA receiving stubs will make a caseless comparison + -- when receiving a call, the calling stubs will create requests with the + -- exact casing of the defining unit name of the called subprogram, so as + -- to allow calls to subprograms on distributed nodes that do distinguish + -- between casings. + -- + -- NOTE: Another design would be to allow a representation clause on + -- subprogram specs: for Subp'Distribution_Identifier use "fooBar"; + + pragma Warnings (Off, Get_Subprogram_Id); + -- One homonym only is unreferenced (specific to the GARLIC version) + + procedure Add_RAS_Dereference_TSS (N : Node_Id); + -- Add a subprogram body for RAS Dereference TSS + + procedure Add_RAS_Proxy_And_Analyze + (Decls : List_Id; + Vis_Decl : Node_Id; + All_Calls_Remote_E : Entity_Id; + Proxy_Object_Addr : out Entity_Id); + -- Add the proxy type required, on the receiving (server) side, to handle + -- calls to the subprogram declared by Vis_Decl through a remote access + -- to subprogram type. All_Calls_Remote_E must be Standard_True if a pragma + -- All_Calls_Remote applies, Standard_False otherwise. The new proxy type + -- is appended to Decls. Proxy_Object_Addr is a constant of type + -- System.Address that designates an instance of the proxy object. + + function Build_Remote_Subprogram_Proxy_Type + (Loc : Source_Ptr; + ACR_Expression : Node_Id) return Node_Id; + -- Build and return a tagged record type definition for an RCI subprogram + -- proxy type. ACR_Expression is used as the initialization value for the + -- All_Calls_Remote component. + + function Build_Get_Unique_RP_Call + (Loc : Source_Ptr; + Pointer : Entity_Id; + Stub_Type : Entity_Id) return List_Id; + -- Build a call to Get_Unique_Remote_Pointer (Pointer), followed by a + -- tag fixup (Get_Unique_Remote_Pointer may have changed Pointer'Tag to + -- RACW_Stub_Type'Tag, while the desired tag is that of Stub_Type). + + function Build_Stub_Tag + (Loc : Source_Ptr; + RACW_Type : Entity_Id) return Node_Id; + -- Return an expression denoting the tag of the stub type associated with + -- RACW_Type. + + function Build_Subprogram_Calling_Stubs + (Vis_Decl : Node_Id; + Subp_Id : Node_Id; + Asynchronous : Boolean; + Dynamically_Asynchronous : Boolean := False; + Stub_Type : Entity_Id := Empty; + RACW_Type : Entity_Id := Empty; + Locator : Entity_Id := Empty; + New_Name : Name_Id := No_Name) return Node_Id; + -- Build the calling stub for a given subprogram with the subprogram ID + -- being Subp_Id. If Stub_Type is given, then the "addr" field of + -- parameters of this type will be marshalled instead of the object itself. + -- It will then be converted into Stub_Type before performing the real + -- call. If Dynamically_Asynchronous is True, then it will be computed at + -- run time whether the call is asynchronous or not. Otherwise, the value + -- of the formal Asynchronous will be used. If Locator is not Empty, it + -- will be used instead of RCI_Cache. If New_Name is given, then it will + -- be used instead of the original name. + + function Build_RPC_Receiver_Specification + (RPC_Receiver : Entity_Id; + Request_Parameter : Entity_Id) return Node_Id; + -- Make a subprogram specification for an RPC receiver, with the given + -- defining unit name and formal parameter. + + function Build_Ordered_Parameters_List (Spec : Node_Id) return List_Id; + -- Return an ordered parameter list: unconstrained parameters are put + -- at the beginning of the list and constrained ones are put after. If + -- there are no parameters, an empty list is returned. Special case: + -- the controlling formal of the equivalent RACW operation for a RAS + -- type is always left in first position. + + function Transmit_As_Unconstrained (Typ : Entity_Id) return Boolean; + -- True when Typ is an unconstrained type, or a null-excluding access type. + -- In either case, this means stubs cannot contain a default-initialized + -- object declaration of such type. + + procedure Add_Calling_Stubs_To_Declarations (Pkg_Spec : Node_Id); + -- Add calling stubs to the declarative part + + function Could_Be_Asynchronous (Spec : Node_Id) return Boolean; + -- Return True if nothing prevents the program whose specification is + -- given to be asynchronous (i.e. no [IN] OUT parameters). + + function Pack_Entity_Into_Stream_Access + (Loc : Source_Ptr; + Stream : Node_Id; + Object : Entity_Id; + Etyp : Entity_Id := Empty) return Node_Id; + -- Pack Object (of type Etyp) into Stream. If Etyp is not given, + -- then Etype (Object) will be used if present. If the type is + -- constrained, then 'Write will be used to output the object, + -- If the type is unconstrained, 'Output will be used. + + function Pack_Node_Into_Stream + (Loc : Source_Ptr; + Stream : Entity_Id; + Object : Node_Id; + Etyp : Entity_Id) return Node_Id; + -- Similar to above, with an arbitrary node instead of an entity + + function Pack_Node_Into_Stream_Access + (Loc : Source_Ptr; + Stream : Node_Id; + Object : Node_Id; + Etyp : Entity_Id) return Node_Id; + -- Similar to above, with Stream instead of Stream'Access + + function Make_Selected_Component + (Loc : Source_Ptr; + Prefix : Entity_Id; + Selector_Name : Name_Id) return Node_Id; + -- Return a selected_component whose prefix denotes the given entity, and + -- with the given Selector_Name. + + function Scope_Of_Spec (Spec : Node_Id) return Entity_Id; + -- Return the scope represented by a given spec + + procedure Set_Renaming_TSS + (Typ : Entity_Id; + Nam : Entity_Id; + TSS_Nam : TSS_Name_Type); + -- Create a renaming declaration of subprogram Nam, and register it as a + -- TSS for Typ with name TSS_Nam. + + function Need_Extra_Constrained (Parameter : Node_Id) return Boolean; + -- Return True if the current parameter needs an extra formal to reflect + -- its constrained status. + + function Is_RACW_Controlling_Formal + (Parameter : Node_Id; + Stub_Type : Entity_Id) return Boolean; + -- Return True if the current parameter is a controlling formal argument + -- of type Stub_Type or access to Stub_Type. + + procedure Declare_Create_NVList + (Loc : Source_Ptr; + NVList : Entity_Id; + Decls : List_Id; + Stmts : List_Id); + -- Append the declaration of NVList to Decls, and its + -- initialization to Stmts. + + function Add_Parameter_To_NVList + (Loc : Source_Ptr; + NVList : Entity_Id; + Parameter : Entity_Id; + Constrained : Boolean; + RACW_Ctrl : Boolean := False; + Any : Entity_Id) return Node_Id; + -- Return a call to Add_Item to add the Any corresponding to the designated + -- formal Parameter (with the indicated Constrained status) to NVList. + -- RACW_Ctrl must be set to True for controlling formals of distributed + -- object primitive operations. + + -------------------- + -- Stub_Structure -- + -------------------- + + -- This record describes various tree fragments associated with the + -- generation of RACW calling stubs. One such record exists for every + -- distributed object type, i.e. each tagged type that is the designated + -- type of one or more RACW type. + + type Stub_Structure is record + Stub_Type : Entity_Id; + -- Stub type: this type has the same primitive operations as the + -- designated types, but the provided bodies for these operations + -- a remote call to an actual target object potentially located on + -- another partition; each value of the stub type encapsulates a + -- reference to a remote object. + + Stub_Type_Access : Entity_Id; + -- A local access type designating the stub type (this is not an RACW + -- type). + + RPC_Receiver_Decl : Node_Id; + -- Declaration for the RPC receiver entity associated with the + -- designated type. As an exception, in the case of GARLIC, for an RACW + -- that implements a RAS, no object RPC receiver is generated. Instead, + -- RPC_Receiver_Decl is the declaration after which the RPC receiver + -- would have been inserted. + + Body_Decls : List_Id; + -- List of subprogram bodies to be included in generated code: bodies + -- for the RACW's stream attributes, and for the primitive operations + -- of the stub type. + + RACW_Type : Entity_Id; + -- One of the RACW types designating this distributed object type + -- (they are all interchangeable; we use any one of them in order to + -- avoid having to create various anonymous access types). + + end record; + + Empty_Stub_Structure : constant Stub_Structure := + (Empty, Empty, Empty, No_List, Empty); + + package Stubs_Table is + new Simple_HTable (Header_Num => Hash_Index, + Element => Stub_Structure, + No_Element => Empty_Stub_Structure, + Key => Entity_Id, + Hash => Hash, + Equal => "="); + -- Mapping between a RACW designated type and its stub type + + package Asynchronous_Flags_Table is + new Simple_HTable (Header_Num => Hash_Index, + Element => Entity_Id, + No_Element => Empty, + Key => Entity_Id, + Hash => Hash, + Equal => "="); + -- Mapping between a RACW type and a constant having the value True + -- if the RACW is asynchronous and False otherwise. + + package RCI_Locator_Table is + new Simple_HTable (Header_Num => Hash_Index, + Element => Entity_Id, + No_Element => Empty, + Key => Entity_Id, + Hash => Hash, + Equal => "="); + -- Mapping between a RCI package on which All_Calls_Remote applies and + -- the generic instantiation of RCI_Locator for this package. + + package RCI_Calling_Stubs_Table is + new Simple_HTable (Header_Num => Hash_Index, + Element => Entity_Id, + No_Element => Empty, + Key => Entity_Id, + Hash => Hash, + Equal => "="); + -- Mapping between a RCI subprogram and the corresponding calling stubs + + function Get_Stub_Elements (RACW_Type : Entity_Id) return Stub_Structure; + -- Return the stub information associated with the given RACW type + + procedure Add_Stub_Type + (Designated_Type : Entity_Id; + RACW_Type : Entity_Id; + Decls : List_Id; + Stub_Type : out Entity_Id; + Stub_Type_Access : out Entity_Id; + RPC_Receiver_Decl : out Node_Id; + Body_Decls : out List_Id; + Existing : out Boolean); + -- Add the declaration of the stub type, the access to stub type and the + -- object RPC receiver at the end of Decls. If these already exist, + -- then nothing is added in the tree but the right values are returned + -- anyhow and Existing is set to True. + + function Get_And_Reset_RACW_Bodies (RACW_Type : Entity_Id) return List_Id; + -- Retrieve the Body_Decls list associated to RACW_Type in the stub + -- structure table, reset it to No_List, and return the previous value. + + procedure Add_RACW_Asynchronous_Flag + (Declarations : List_Id; + RACW_Type : Entity_Id); + -- Declare a boolean constant associated with RACW_Type whose value + -- indicates at run time whether a pragma Asynchronous applies to it. + + procedure Assign_Subprogram_Identifier + (Def : Entity_Id; + Spn : Int; + Id : out String_Id); + -- Determine the distribution subprogram identifier to + -- be used for remote subprogram Def, return it in Id and + -- store it in a hash table for later retrieval by + -- Get_Subprogram_Id. Spn is the subprogram number. + + function RCI_Package_Locator + (Loc : Source_Ptr; + Package_Spec : Node_Id) return Node_Id; + -- Instantiate the generic package RCI_Locator in order to locate the + -- RCI package whose spec is given as argument. + + function Make_Tag_Check (Loc : Source_Ptr; N : Node_Id) return Node_Id; + -- Surround a node N by a tag check, as in: + -- begin + -- <N>; + -- exception + -- when E : Ada.Tags.Tag_Error => + -- Raise_Exception (Program_Error'Identity, + -- Exception_Message (E)); + -- end; + + function Input_With_Tag_Check + (Loc : Source_Ptr; + Var_Type : Entity_Id; + Stream : Node_Id) return Node_Id; + -- Return a function with the following form: + -- function R return Var_Type is + -- begin + -- return Var_Type'Input (S); + -- exception + -- when E : Ada.Tags.Tag_Error => + -- Raise_Exception (Program_Error'Identity, + -- Exception_Message (E)); + -- end R; + + procedure Build_Actual_Object_Declaration + (Object : Entity_Id; + Etyp : Entity_Id; + Variable : Boolean; + Expr : Node_Id; + Decls : List_Id); + -- Build the declaration of an object with the given defining identifier, + -- initialized with Expr if provided, to serve as actual parameter in a + -- server stub. If Variable is true, the declared object will be a variable + -- (case of an out or in out formal), else it will be a constant. Object's + -- Ekind is set accordingly. The declaration, as well as any other + -- declarations it requires, are appended to Decls. + + -------------------------------------------- + -- Hooks for PCS-specific code generation -- + -------------------------------------------- + + -- Part of the code generation circuitry for distribution needs to be + -- tailored for each implementation of the PCS. For each routine that + -- needs to be specialized, a Specific_<routine> wrapper is created, + -- which calls the corresponding <routine> in package + -- <pcs_implementation>_Support. + + procedure Specific_Add_RACW_Features + (RACW_Type : Entity_Id; + Desig : Entity_Id; + Stub_Type : Entity_Id; + Stub_Type_Access : Entity_Id; + RPC_Receiver_Decl : Node_Id; + Body_Decls : List_Id); + -- Add declaration for TSSs for a given RACW type. The declarations are + -- added just after the declaration of the RACW type itself. If the RACW + -- appears in the main unit, Body_Decls is a list of declarations to which + -- the bodies are appended. Else Body_Decls is No_List. + -- PCS-specific ancillary subprogram for Add_RACW_Features. + + procedure Specific_Add_RAST_Features + (Vis_Decl : Node_Id; + RAS_Type : Entity_Id); + -- Add declaration for TSSs for a given RAS type. PCS-specific ancillary + -- subprogram for Add_RAST_Features. + + -- An RPC_Target record is used during construction of calling stubs + -- to pass PCS-specific tree fragments corresponding to the information + -- necessary to locate the target of a remote subprogram call. + + type RPC_Target (PCS_Kind : PCS_Names) is record + case PCS_Kind is + when Name_PolyORB_DSA => + Object : Node_Id; + -- An expression whose value is a PolyORB reference to the target + -- object. + + when others => + Partition : Entity_Id; + -- A variable containing the Partition_ID of the target partition + + RPC_Receiver : Node_Id; + -- An expression whose value is the address of the target RPC + -- receiver. + end case; + end record; + + procedure Specific_Build_General_Calling_Stubs + (Decls : List_Id; + Statements : List_Id; + Target : RPC_Target; + Subprogram_Id : Node_Id; + Asynchronous : Node_Id := Empty; + Is_Known_Asynchronous : Boolean := False; + Is_Known_Non_Asynchronous : Boolean := False; + Is_Function : Boolean; + Spec : Node_Id; + Stub_Type : Entity_Id := Empty; + RACW_Type : Entity_Id := Empty; + Nod : Node_Id); + -- Build calling stubs for general purpose. The parameters are: + -- Decls : a place to put declarations + -- Statements : a place to put statements + -- Target : PCS-specific target information (see details + -- in RPC_Target declaration). + -- Subprogram_Id : a node containing the subprogram ID + -- Asynchronous : True if an APC must be made instead of an RPC. + -- The value needs not be supplied if one of the + -- Is_Known_... is True. + -- Is_Known_Async... : True if we know that this is asynchronous + -- Is_Known_Non_A... : True if we know that this is not asynchronous + -- Spec : a node with a Parameter_Specifications and + -- a Result_Definition if applicable + -- Stub_Type : in case of RACW stubs, parameters of type access + -- to Stub_Type will be marshalled using the + -- address of the object (the addr field) rather + -- than using the 'Write on the stub itself + -- Nod : used to provide sloc for generated code + + function Specific_Build_Stub_Target + (Loc : Source_Ptr; + Decls : List_Id; + RCI_Locator : Entity_Id; + Controlling_Parameter : Entity_Id) return RPC_Target; + -- Build call target information nodes for use within calling stubs. In the + -- RCI case, RCI_Locator is the entity for the instance of RCI_Locator. If + -- for an RACW, Controlling_Parameter is the entity for the controlling + -- formal parameter used to determine the location of the target of the + -- call. Decls provides a location where variable declarations can be + -- appended to construct the necessary values. + + function Specific_RPC_Receiver_Decl + (RACW_Type : Entity_Id) return Node_Id; + -- Build the RPC receiver, for RACW, if applicable, else return Empty + + procedure Specific_Build_RPC_Receiver_Body + (RPC_Receiver : Entity_Id; + Request : out Entity_Id; + Subp_Id : out Entity_Id; + Subp_Index : out Entity_Id; + Stmts : out List_Id; + Decl : out Node_Id); + -- Make a subprogram body for an RPC receiver, with the given + -- defining unit name. On return: + -- - Subp_Id is the subprogram identifier from the PCS. + -- - Subp_Index is the index in the list of subprograms + -- used for dispatching (a variable of type Subprogram_Id). + -- - Stmts is the place where the request dispatching + -- statements can occur, + -- - Decl is the subprogram body declaration. + + function Specific_Build_Subprogram_Receiving_Stubs + (Vis_Decl : Node_Id; + Asynchronous : Boolean; + Dynamically_Asynchronous : Boolean := False; + Stub_Type : Entity_Id := Empty; + RACW_Type : Entity_Id := Empty; + Parent_Primitive : Entity_Id := Empty) return Node_Id; + -- Build the receiving stub for a given subprogram. The subprogram + -- declaration is also built by this procedure, and the value returned + -- is a N_Subprogram_Body. If a parameter of type access to Stub_Type is + -- found in the specification, then its address is read from the stream + -- instead of the object itself and converted into an access to + -- class-wide type before doing the real call using any of the RACW type + -- pointing on the designated type. + + procedure Specific_Add_Obj_RPC_Receiver_Completion + (Loc : Source_Ptr; + Decls : List_Id; + RPC_Receiver : Entity_Id; + Stub_Elements : Stub_Structure); + -- Add the necessary code to Decls after the completion of generation + -- of the RACW RPC receiver described by Stub_Elements. + + procedure Specific_Add_Receiving_Stubs_To_Declarations + (Pkg_Spec : Node_Id; + Decls : List_Id; + Stmts : List_Id); + -- Add receiving stubs to the declarative part of an RCI unit + + -------------------- + -- GARLIC_Support -- + -------------------- + + package GARLIC_Support is + + -- Support for generating DSA code that uses the GARLIC PCS + + -- The subprograms below provide the GARLIC versions of the + -- corresponding Specific_<subprogram> routine declared above. + + procedure Add_RACW_Features + (RACW_Type : Entity_Id; + Stub_Type : Entity_Id; + Stub_Type_Access : Entity_Id; + RPC_Receiver_Decl : Node_Id; + Body_Decls : List_Id); + + procedure Add_RAST_Features + (Vis_Decl : Node_Id; + RAS_Type : Entity_Id); + + procedure Build_General_Calling_Stubs + (Decls : List_Id; + Statements : List_Id; + Target_Partition : Entity_Id; -- From RPC_Target + Target_RPC_Receiver : Node_Id; -- From RPC_Target + Subprogram_Id : Node_Id; + Asynchronous : Node_Id := Empty; + Is_Known_Asynchronous : Boolean := False; + Is_Known_Non_Asynchronous : Boolean := False; + Is_Function : Boolean; + Spec : Node_Id; + Stub_Type : Entity_Id := Empty; + RACW_Type : Entity_Id := Empty; + Nod : Node_Id); + + function Build_Stub_Target + (Loc : Source_Ptr; + Decls : List_Id; + RCI_Locator : Entity_Id; + Controlling_Parameter : Entity_Id) return RPC_Target; + + function RPC_Receiver_Decl (RACW_Type : Entity_Id) return Node_Id; + + function Build_Subprogram_Receiving_Stubs + (Vis_Decl : Node_Id; + Asynchronous : Boolean; + Dynamically_Asynchronous : Boolean := False; + Stub_Type : Entity_Id := Empty; + RACW_Type : Entity_Id := Empty; + Parent_Primitive : Entity_Id := Empty) return Node_Id; + + procedure Add_Obj_RPC_Receiver_Completion + (Loc : Source_Ptr; + Decls : List_Id; + RPC_Receiver : Entity_Id; + Stub_Elements : Stub_Structure); + + procedure Add_Receiving_Stubs_To_Declarations + (Pkg_Spec : Node_Id; + Decls : List_Id; + Stmts : List_Id); + + procedure Build_RPC_Receiver_Body + (RPC_Receiver : Entity_Id; + Request : out Entity_Id; + Subp_Id : out Entity_Id; + Subp_Index : out Entity_Id; + Stmts : out List_Id; + Decl : out Node_Id); + + end GARLIC_Support; + + --------------------- + -- PolyORB_Support -- + --------------------- + + package PolyORB_Support is + + -- Support for generating DSA code that uses the PolyORB PCS + + -- The subprograms below provide the PolyORB versions of the + -- corresponding Specific_<subprogram> routine declared above. + + procedure Add_RACW_Features + (RACW_Type : Entity_Id; + Desig : Entity_Id; + Stub_Type : Entity_Id; + Stub_Type_Access : Entity_Id; + RPC_Receiver_Decl : Node_Id; + Body_Decls : List_Id); + + procedure Add_RAST_Features + (Vis_Decl : Node_Id; + RAS_Type : Entity_Id); + + procedure Build_General_Calling_Stubs + (Decls : List_Id; + Statements : List_Id; + Target_Object : Node_Id; -- From RPC_Target + Subprogram_Id : Node_Id; + Asynchronous : Node_Id := Empty; + Is_Known_Asynchronous : Boolean := False; + Is_Known_Non_Asynchronous : Boolean := False; + Is_Function : Boolean; + Spec : Node_Id; + Stub_Type : Entity_Id := Empty; + RACW_Type : Entity_Id := Empty; + Nod : Node_Id); + + function Build_Stub_Target + (Loc : Source_Ptr; + Decls : List_Id; + RCI_Locator : Entity_Id; + Controlling_Parameter : Entity_Id) return RPC_Target; + + function RPC_Receiver_Decl (RACW_Type : Entity_Id) return Node_Id; + + function Build_Subprogram_Receiving_Stubs + (Vis_Decl : Node_Id; + Asynchronous : Boolean; + Dynamically_Asynchronous : Boolean := False; + Stub_Type : Entity_Id := Empty; + RACW_Type : Entity_Id := Empty; + Parent_Primitive : Entity_Id := Empty) return Node_Id; + + procedure Add_Obj_RPC_Receiver_Completion + (Loc : Source_Ptr; + Decls : List_Id; + RPC_Receiver : Entity_Id; + Stub_Elements : Stub_Structure); + + procedure Add_Receiving_Stubs_To_Declarations + (Pkg_Spec : Node_Id; + Decls : List_Id; + Stmts : List_Id); + + procedure Build_RPC_Receiver_Body + (RPC_Receiver : Entity_Id; + Request : out Entity_Id; + Subp_Id : out Entity_Id; + Subp_Index : out Entity_Id; + Stmts : out List_Id; + Decl : out Node_Id); + + procedure Reserve_NamingContext_Methods; + -- Mark the method names for interface NamingContext as already used in + -- the overload table, so no clashes occur with user code (with the + -- PolyORB PCS, RCIs Implement The NamingContext interface to allow + -- their methods to be accessed as objects, for the implementation of + -- remote access-to-subprogram types). + + ------------- + -- Helpers -- + ------------- + + package Helpers is + + -- Routines to build distribution helper subprograms for user-defined + -- types. For implementation of the Distributed systems annex (DSA) + -- over the PolyORB generic middleware components, it is necessary to + -- generate several supporting subprograms for each application data + -- type used in inter-partition communication. These subprograms are: + + -- A Typecode function returning a high-level description of the + -- type's structure; + + -- Two conversion functions allowing conversion of values of the + -- type from and to the generic data containers used by PolyORB. + -- These generic containers are called 'Any' type values after the + -- CORBA terminology, and hence the conversion subprograms are + -- named To_Any and From_Any. + + function Build_From_Any_Call + (Typ : Entity_Id; + N : Node_Id; + Decls : List_Id) return Node_Id; + -- Build call to From_Any attribute function of type Typ with + -- expression N as actual parameter. Decls is the declarations list + -- for an appropriate enclosing scope of the point where the call + -- will be inserted; if the From_Any attribute for Typ needs to be + -- generated at this point, its declaration is appended to Decls. + + procedure Build_From_Any_Function + (Loc : Source_Ptr; + Typ : Entity_Id; + Decl : out Node_Id; + Fnam : out Entity_Id); + -- Build From_Any attribute function for Typ. Loc is the reference + -- location for generated nodes, Typ is the type for which the + -- conversion function is generated. On return, Decl and Fnam contain + -- the declaration and entity for the newly-created function. + + function Build_To_Any_Call + (Loc : Source_Ptr; + N : Node_Id; + Decls : List_Id) return Node_Id; + -- Build call to To_Any attribute function with expression as actual + -- parameter. Loc is the reference location ofr generated nodes, + -- Decls is the declarations list for an appropriate enclosing scope + -- of the point where the call will be inserted; if the To_Any + -- attribute for the type of N needs to be generated at this point, + -- its declaration is appended to Decls. + + procedure Build_To_Any_Function + (Loc : Source_Ptr; + Typ : Entity_Id; + Decl : out Node_Id; + Fnam : out Entity_Id); + -- Build To_Any attribute function for Typ. Loc is the reference + -- location for generated nodes, Typ is the type for which the + -- conversion function is generated. On return, Decl and Fnam contain + -- the declaration and entity for the newly-created function. + + function Build_TypeCode_Call + (Loc : Source_Ptr; + Typ : Entity_Id; + Decls : List_Id) return Node_Id; + -- Build call to TypeCode attribute function for Typ. Decls is the + -- declarations list for an appropriate enclosing scope of the point + -- where the call will be inserted; if the To_Any attribute for Typ + -- needs to be generated at this point, its declaration is appended + -- to Decls. + + procedure Build_TypeCode_Function + (Loc : Source_Ptr; + Typ : Entity_Id; + Decl : out Node_Id; + Fnam : out Entity_Id); + -- Build TypeCode attribute function for Typ. Loc is the reference + -- location for generated nodes, Typ is the type for which the + -- typecode function is generated. On return, Decl and Fnam contain + -- the declaration and entity for the newly-created function. + + procedure Build_Name_And_Repository_Id + (E : Entity_Id; + Name_Str : out String_Id; + Repo_Id_Str : out String_Id); + -- In the PolyORB distribution model, each distributed object type + -- and each distributed operation has a globally unique identifier, + -- its Repository Id. This subprogram builds and returns two strings + -- for entity E (a distributed object type or operation): one + -- containing the name of E, the second containing its repository id. + + procedure Assign_Opaque_From_Any + (Loc : Source_Ptr; + Stms : List_Id; + Typ : Entity_Id; + N : Node_Id; + Target : Entity_Id); + -- For a Target object of type Typ, which has opaque representation + -- as a sequence of octets determined by stream attributes (which + -- includes all limited types), append code to Stmts performing the + -- equivalent of: + -- Target := Typ'From_Any (N) + -- + -- or, if Target is Empty: + -- return Typ'From_Any (N) + + end Helpers; + + end PolyORB_Support; + + -- The following PolyORB-specific subprograms are made visible to Exp_Attr: + + function Build_From_Any_Call + (Typ : Entity_Id; + N : Node_Id; + Decls : List_Id) return Node_Id + renames PolyORB_Support.Helpers.Build_From_Any_Call; + + function Build_To_Any_Call + (Loc : Source_Ptr; + N : Node_Id; + Decls : List_Id) return Node_Id + renames PolyORB_Support.Helpers.Build_To_Any_Call; + + function Build_TypeCode_Call + (Loc : Source_Ptr; + Typ : Entity_Id; + Decls : List_Id) return Node_Id + renames PolyORB_Support.Helpers.Build_TypeCode_Call; + + ------------------------------------ + -- Local variables and structures -- + ------------------------------------ + + RCI_Cache : Node_Id; + -- Needs comments ??? + + Output_From_Constrained : constant array (Boolean) of Name_Id := + (False => Name_Output, + True => Name_Write); + -- The attribute to choose depending on the fact that the parameter + -- is constrained or not. There is no such thing as Input_From_Constrained + -- since this require separate mechanisms ('Input is a function while + -- 'Read is a procedure). + + generic + with procedure Process_Subprogram_Declaration (Decl : Node_Id); + -- Generate calling or receiving stub for this subprogram declaration + + procedure Build_Package_Stubs (Pkg_Spec : Node_Id); + -- Recursively visit the given RCI Package_Specification, calling + -- Process_Subprogram_Declaration for each remote subprogram. + + ------------------------- + -- Build_Package_Stubs -- + ------------------------- + + procedure Build_Package_Stubs (Pkg_Spec : Node_Id) is + Decls : constant List_Id := Visible_Declarations (Pkg_Spec); + Decl : Node_Id; + + procedure Visit_Nested_Pkg (Nested_Pkg_Decl : Node_Id); + -- Recurse for the given nested package declaration + + ----------------------- + -- Visit_Nested_Spec -- + ----------------------- + + procedure Visit_Nested_Pkg (Nested_Pkg_Decl : Node_Id) is + Nested_Pkg_Spec : constant Node_Id := Specification (Nested_Pkg_Decl); + begin + Push_Scope (Scope_Of_Spec (Nested_Pkg_Spec)); + Build_Package_Stubs (Nested_Pkg_Spec); + Pop_Scope; + end Visit_Nested_Pkg; + + -- Start of processing for Build_Package_Stubs + + begin + Decl := First (Decls); + while Present (Decl) loop + case Nkind (Decl) is + when N_Subprogram_Declaration => + + -- Note: we test Comes_From_Source on Spec, not Decl, because + -- in the case of a subprogram instance, only the specification + -- (not the declaration) is marked as coming from source. + + if Comes_From_Source (Specification (Decl)) then + Process_Subprogram_Declaration (Decl); + end if; + + when N_Package_Declaration => + + -- Case of a nested package or package instantiation coming + -- from source. Note that the anonymous wrapper package for + -- subprogram instances is not flagged Is_Generic_Instance at + -- this point, so there is a distinct circuit to handle them + -- (see case N_Subprogram_Instantiation below). + + declare + Pkg_Ent : constant Entity_Id := + Defining_Unit_Name (Specification (Decl)); + begin + if Comes_From_Source (Decl) + or else + (Is_Generic_Instance (Pkg_Ent) + and then Comes_From_Source + (Get_Package_Instantiation_Node (Pkg_Ent))) + then + Visit_Nested_Pkg (Decl); + end if; + end; + + when N_Subprogram_Instantiation => + + -- The subprogram declaration for an instance of a generic + -- subprogram is wrapped in a package that does not come from + -- source, so we need to explicitly traverse it here. + + if Comes_From_Source (Decl) then + Visit_Nested_Pkg (Instance_Spec (Decl)); + end if; + + when others => + null; + end case; + Next (Decl); + end loop; + end Build_Package_Stubs; + + --------------------------------------- + -- Add_Calling_Stubs_To_Declarations -- + --------------------------------------- + + procedure Add_Calling_Stubs_To_Declarations (Pkg_Spec : Node_Id) is + Loc : constant Source_Ptr := Sloc (Pkg_Spec); + + Current_Subprogram_Number : Int := First_RCI_Subprogram_Id; + -- Subprogram id 0 is reserved for calls received from + -- remote access-to-subprogram dereferences. + + RCI_Instantiation : Node_Id; + + procedure Visit_Subprogram (Decl : Node_Id); + -- Generate calling stub for one remote subprogram + + ---------------------- + -- Visit_Subprogram -- + ---------------------- + + procedure Visit_Subprogram (Decl : Node_Id) is + Loc : constant Source_Ptr := Sloc (Decl); + Spec : constant Node_Id := Specification (Decl); + Subp_Stubs : Node_Id; + + Subp_Str : String_Id; + pragma Warnings (Off, Subp_Str); + + begin + -- Disable expansion of stubs if serious errors have been diagnosed, + -- because otherwise some illegal remote subprogram declarations + -- could cause cascaded errors in stubs. + + if Serious_Errors_Detected /= 0 then + return; + end if; + + Assign_Subprogram_Identifier + (Defining_Unit_Name (Spec), Current_Subprogram_Number, Subp_Str); + + Subp_Stubs := + Build_Subprogram_Calling_Stubs + (Vis_Decl => Decl, + Subp_Id => + Build_Subprogram_Id (Loc, Defining_Unit_Name (Spec)), + Asynchronous => + Nkind (Spec) = N_Procedure_Specification + and then Is_Asynchronous (Defining_Unit_Name (Spec))); + + Append_To (List_Containing (Decl), Subp_Stubs); + Analyze (Subp_Stubs); + + Current_Subprogram_Number := Current_Subprogram_Number + 1; + end Visit_Subprogram; + + procedure Visit_Spec is new Build_Package_Stubs (Visit_Subprogram); + + -- Start of processing for Add_Calling_Stubs_To_Declarations + + begin + Push_Scope (Scope_Of_Spec (Pkg_Spec)); + + -- The first thing added is an instantiation of the generic package + -- System.Partition_Interface.RCI_Locator with the name of this remote + -- package. This will act as an interface with the name server to + -- determine the Partition_ID and the RPC_Receiver for the receiver + -- of this package. + + RCI_Instantiation := RCI_Package_Locator (Loc, Pkg_Spec); + RCI_Cache := Defining_Unit_Name (RCI_Instantiation); + + Append_To (Visible_Declarations (Pkg_Spec), RCI_Instantiation); + Analyze (RCI_Instantiation); + + -- For each subprogram declaration visible in the spec, we do build a + -- body. We also increment a counter to assign a different Subprogram_Id + -- to each subprogram. The receiving stubs processing uses the same + -- mechanism and will thus assign the same Id and do the correct + -- dispatching. + + Overload_Counter_Table.Reset; + PolyORB_Support.Reserve_NamingContext_Methods; + + Visit_Spec (Pkg_Spec); + + Pop_Scope; + end Add_Calling_Stubs_To_Declarations; + + ----------------------------- + -- Add_Parameter_To_NVList -- + ----------------------------- + + function Add_Parameter_To_NVList + (Loc : Source_Ptr; + NVList : Entity_Id; + Parameter : Entity_Id; + Constrained : Boolean; + RACW_Ctrl : Boolean := False; + Any : Entity_Id) return Node_Id + is + Parameter_Name_String : String_Id; + Parameter_Mode : Node_Id; + + function Parameter_Passing_Mode + (Loc : Source_Ptr; + Parameter : Entity_Id; + Constrained : Boolean) return Node_Id; + -- Return an expression that denotes the parameter passing mode to be + -- used for Parameter in distribution stubs, where Constrained is + -- Parameter's constrained status. + + ---------------------------- + -- Parameter_Passing_Mode -- + ---------------------------- + + function Parameter_Passing_Mode + (Loc : Source_Ptr; + Parameter : Entity_Id; + Constrained : Boolean) return Node_Id + is + Lib_RE : RE_Id; + + begin + if Out_Present (Parameter) then + if In_Present (Parameter) + or else not Constrained + then + -- Unconstrained formals must be translated + -- to 'in' or 'inout', not 'out', because + -- they need to be constrained by the actual. + + Lib_RE := RE_Mode_Inout; + else + Lib_RE := RE_Mode_Out; + end if; + + else + Lib_RE := RE_Mode_In; + end if; + + return New_Occurrence_Of (RTE (Lib_RE), Loc); + end Parameter_Passing_Mode; + + -- Start of processing for Add_Parameter_To_NVList + + begin + if Nkind (Parameter) = N_Defining_Identifier then + Get_Name_String (Chars (Parameter)); + else + Get_Name_String (Chars (Defining_Identifier (Parameter))); + end if; + + Parameter_Name_String := String_From_Name_Buffer; + + if RACW_Ctrl or else Nkind (Parameter) = N_Defining_Identifier then + + -- When the parameter passed to Add_Parameter_To_NVList is an + -- Extra_Constrained parameter, Parameter is an N_Defining_ + -- Identifier, instead of a complete N_Parameter_Specification. + -- Thus, we explicitly set 'in' mode in this case. + + Parameter_Mode := New_Occurrence_Of (RTE (RE_Mode_In), Loc); + + else + Parameter_Mode := + Parameter_Passing_Mode (Loc, Parameter, Constrained); + end if; + + return + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of + (RTE (RE_NVList_Add_Item), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (NVList, Loc), + Make_Function_Call (Loc, + Name => + New_Occurrence_Of + (RTE (RE_To_PolyORB_String), Loc), + Parameter_Associations => New_List ( + Make_String_Literal (Loc, + Strval => Parameter_Name_String))), + New_Occurrence_Of (Any, Loc), + Parameter_Mode)); + end Add_Parameter_To_NVList; + + -------------------------------- + -- Add_RACW_Asynchronous_Flag -- + -------------------------------- + + procedure Add_RACW_Asynchronous_Flag + (Declarations : List_Id; + RACW_Type : Entity_Id) + is + Loc : constant Source_Ptr := Sloc (RACW_Type); + + Asynchronous_Flag : constant Entity_Id := + Make_Defining_Identifier (Loc, + New_External_Name (Chars (RACW_Type), 'A')); + + begin + -- Declare the asynchronous flag. This flag will be changed to True + -- whenever it is known that the RACW type is asynchronous. + + Append_To (Declarations, + Make_Object_Declaration (Loc, + Defining_Identifier => Asynchronous_Flag, + Constant_Present => True, + Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc), + Expression => New_Occurrence_Of (Standard_False, Loc))); + + Asynchronous_Flags_Table.Set (RACW_Type, Asynchronous_Flag); + end Add_RACW_Asynchronous_Flag; + + ----------------------- + -- Add_RACW_Features -- + ----------------------- + + procedure Add_RACW_Features (RACW_Type : Entity_Id) is + Desig : constant Entity_Id := Etype (Designated_Type (RACW_Type)); + Same_Scope : constant Boolean := Scope (Desig) = Scope (RACW_Type); + + Pkg_Spec : Node_Id; + Decls : List_Id; + Body_Decls : List_Id; + + Stub_Type : Entity_Id; + Stub_Type_Access : Entity_Id; + RPC_Receiver_Decl : Node_Id; + + Existing : Boolean; + -- True when appropriate stubs have already been generated (this is the + -- case when another RACW with the same designated type has already been + -- encountered), in which case we reuse the previous stubs rather than + -- generating new ones. + + begin + if not Expander_Active then + return; + end if; + + -- Mark the current package declaration as containing an RACW, so that + -- the bodies for the calling stubs and the RACW stream subprograms + -- are attached to the tree when the corresponding body is encountered. + + Set_Has_RACW (Current_Scope); + + -- Look for place to declare the RACW stub type and RACW operations + + Pkg_Spec := Empty; + + if Same_Scope then + + -- Case of declaring the RACW in the same package as its designated + -- type: we know that the designated type is a private type, so we + -- use the private declarations list. + + Pkg_Spec := Package_Specification_Of_Scope (Current_Scope); + + if Present (Private_Declarations (Pkg_Spec)) then + Decls := Private_Declarations (Pkg_Spec); + else + Decls := Visible_Declarations (Pkg_Spec); + end if; + + else + -- Case of declaring the RACW in another package than its designated + -- type: use the private declarations list if present; otherwise + -- use the visible declarations. + + Decls := List_Containing (Declaration_Node (RACW_Type)); + + end if; + + -- If we were unable to find the declarations, that means that the + -- completion of the type was missing. We can safely return and let the + -- error be caught by the semantic analysis. + + if No (Decls) then + return; + end if; + + Add_Stub_Type + (Designated_Type => Desig, + RACW_Type => RACW_Type, + Decls => Decls, + Stub_Type => Stub_Type, + Stub_Type_Access => Stub_Type_Access, + RPC_Receiver_Decl => RPC_Receiver_Decl, + Body_Decls => Body_Decls, + Existing => Existing); + + -- If this RACW is not in the main unit, do not generate primitive or + -- TSS bodies. + + if not Entity_Is_In_Main_Unit (RACW_Type) then + Body_Decls := No_List; + end if; + + Add_RACW_Asynchronous_Flag + (Declarations => Decls, + RACW_Type => RACW_Type); + + Specific_Add_RACW_Features + (RACW_Type => RACW_Type, + Desig => Desig, + Stub_Type => Stub_Type, + Stub_Type_Access => Stub_Type_Access, + RPC_Receiver_Decl => RPC_Receiver_Decl, + Body_Decls => Body_Decls); + + -- If we already have stubs for this designated type, nothing to do + + if Existing then + return; + end if; + + if Is_Frozen (Desig) then + Validate_RACW_Primitives (RACW_Type); + Add_RACW_Primitive_Declarations_And_Bodies + (Designated_Type => Desig, + Insertion_Node => RPC_Receiver_Decl, + Body_Decls => Body_Decls); + + else + -- Validate_RACW_Primitives requires the list of all primitives of + -- the designated type, so defer processing until Desig is frozen. + -- See Exp_Ch3.Freeze_Type. + + Add_Access_Type_To_Process (E => Desig, A => RACW_Type); + end if; + end Add_RACW_Features; + + ------------------------------------------------ + -- Add_RACW_Primitive_Declarations_And_Bodies -- + ------------------------------------------------ + + procedure Add_RACW_Primitive_Declarations_And_Bodies + (Designated_Type : Entity_Id; + Insertion_Node : Node_Id; + Body_Decls : List_Id) + is + Loc : constant Source_Ptr := Sloc (Insertion_Node); + -- Set Sloc of generated declaration copy of insertion node Sloc, so + -- the declarations are recognized as belonging to the current package. + + Stub_Elements : constant Stub_Structure := + Stubs_Table.Get (Designated_Type); + + pragma Assert (Stub_Elements /= Empty_Stub_Structure); + + Is_RAS : constant Boolean := + not Comes_From_Source (Stub_Elements.RACW_Type); + -- Case of the RACW generated to implement a remote access-to- + -- subprogram type. + + Build_Bodies : constant Boolean := + In_Extended_Main_Code_Unit (Stub_Elements.Stub_Type); + -- True when bodies must be prepared in Body_Decls. Bodies are generated + -- only when the main unit is the unit that contains the stub type. + + Current_Insertion_Node : Node_Id := Insertion_Node; + + RPC_Receiver : Entity_Id; + RPC_Receiver_Statements : List_Id; + RPC_Receiver_Case_Alternatives : constant List_Id := New_List; + RPC_Receiver_Elsif_Parts : List_Id; + RPC_Receiver_Request : Entity_Id; + RPC_Receiver_Subp_Id : Entity_Id; + RPC_Receiver_Subp_Index : Entity_Id; + + Subp_Str : String_Id; + + Current_Primitive_Elmt : Elmt_Id; + Current_Primitive : Entity_Id; + Current_Primitive_Body : Node_Id; + Current_Primitive_Spec : Node_Id; + Current_Primitive_Decl : Node_Id; + Current_Primitive_Number : Int := 0; + Current_Primitive_Alias : Node_Id; + Current_Receiver : Entity_Id; + Current_Receiver_Body : Node_Id; + RPC_Receiver_Decl : Node_Id; + Possibly_Asynchronous : Boolean; + + begin + if not Expander_Active then + return; + end if; + + if not Is_RAS then + RPC_Receiver := Make_Temporary (Loc, 'P'); + + Specific_Build_RPC_Receiver_Body + (RPC_Receiver => RPC_Receiver, + Request => RPC_Receiver_Request, + Subp_Id => RPC_Receiver_Subp_Id, + Subp_Index => RPC_Receiver_Subp_Index, + Stmts => RPC_Receiver_Statements, + Decl => RPC_Receiver_Decl); + + if Get_PCS_Name = Name_PolyORB_DSA then + + -- For the case of PolyORB, we need to map a textual operation + -- name into a primitive index. Currently we do so using a simple + -- sequence of string comparisons. + + RPC_Receiver_Elsif_Parts := New_List; + end if; + end if; + + -- Build callers, receivers for every primitive operations and a RPC + -- receiver for this type. Note that we use Direct_Primitive_Operations, + -- not Primitive_Operations, because we really want just the primitives + -- of the tagged type itself, and in the case of a tagged synchronized + -- type we do not want to get the primitives of the corresponding + -- record type). + + if Present (Direct_Primitive_Operations (Designated_Type)) then + Overload_Counter_Table.Reset; + + Current_Primitive_Elmt := + First_Elmt (Direct_Primitive_Operations (Designated_Type)); + while Current_Primitive_Elmt /= No_Elmt loop + Current_Primitive := Node (Current_Primitive_Elmt); + + -- Copy the primitive of all the parents, except predefined ones + -- that are not remotely dispatching. Also omit hidden primitives + -- (occurs in the case of primitives of interface progenitors + -- other than immediate ancestors of the Designated_Type). + + if Chars (Current_Primitive) /= Name_uSize + and then Chars (Current_Primitive) /= Name_uAlignment + and then not + (Is_TSS (Current_Primitive, TSS_Deep_Finalize) or else + Is_TSS (Current_Primitive, TSS_Stream_Input) or else + Is_TSS (Current_Primitive, TSS_Stream_Output) or else + Is_TSS (Current_Primitive, TSS_Stream_Read) or else + Is_TSS (Current_Primitive, TSS_Stream_Write) + or else + Is_Predefined_Interface_Primitive (Current_Primitive)) + and then not Is_Hidden (Current_Primitive) + then + -- The first thing to do is build an up-to-date copy of the + -- spec with all the formals referencing Controlling_Type + -- transformed into formals referencing Stub_Type. Since this + -- primitive may have been inherited, go back the alias chain + -- until the real primitive has been found. + + Current_Primitive_Alias := Ultimate_Alias (Current_Primitive); + + -- Copy the spec from the original declaration for the purpose + -- of declaring an overriding subprogram: we need to replace + -- the type of each controlling formal with Stub_Type. The + -- primitive may have been declared for Controlling_Type or + -- inherited from some ancestor type for which we do not have + -- an easily determined Entity_Id. We have no systematic way + -- of knowing which type to substitute Stub_Type for. Instead, + -- Copy_Specification relies on the flag Is_Controlling_Formal + -- to determine which formals to change. + + Current_Primitive_Spec := + Copy_Specification (Loc, + Spec => Parent (Current_Primitive_Alias), + Ctrl_Type => Stub_Elements.Stub_Type); + + Current_Primitive_Decl := + Make_Subprogram_Declaration (Loc, + Specification => Current_Primitive_Spec); + + Insert_After_And_Analyze (Current_Insertion_Node, + Current_Primitive_Decl); + Current_Insertion_Node := Current_Primitive_Decl; + + Possibly_Asynchronous := + Nkind (Current_Primitive_Spec) = N_Procedure_Specification + and then Could_Be_Asynchronous (Current_Primitive_Spec); + + Assign_Subprogram_Identifier ( + Defining_Unit_Name (Current_Primitive_Spec), + Current_Primitive_Number, + Subp_Str); + + if Build_Bodies then + Current_Primitive_Body := + Build_Subprogram_Calling_Stubs + (Vis_Decl => Current_Primitive_Decl, + Subp_Id => + Build_Subprogram_Id (Loc, + Defining_Unit_Name (Current_Primitive_Spec)), + Asynchronous => Possibly_Asynchronous, + Dynamically_Asynchronous => Possibly_Asynchronous, + Stub_Type => Stub_Elements.Stub_Type, + RACW_Type => Stub_Elements.RACW_Type); + Append_To (Body_Decls, Current_Primitive_Body); + + -- Analyzing the body here would cause the Stub type to + -- be frozen, thus preventing subsequent primitive + -- declarations. For this reason, it will be analyzed + -- later in the regular flow (and in the context of the + -- appropriate unit body, see Append_RACW_Bodies). + + end if; + + -- Build the receiver stubs + + if Build_Bodies and then not Is_RAS then + Current_Receiver_Body := + Specific_Build_Subprogram_Receiving_Stubs + (Vis_Decl => Current_Primitive_Decl, + Asynchronous => Possibly_Asynchronous, + Dynamically_Asynchronous => Possibly_Asynchronous, + Stub_Type => Stub_Elements.Stub_Type, + RACW_Type => Stub_Elements.RACW_Type, + Parent_Primitive => Current_Primitive); + + Current_Receiver := + Defining_Unit_Name (Specification (Current_Receiver_Body)); + + Append_To (Body_Decls, Current_Receiver_Body); + + -- Add a case alternative to the receiver + + if Get_PCS_Name = Name_PolyORB_DSA then + Append_To (RPC_Receiver_Elsif_Parts, + Make_Elsif_Part (Loc, + Condition => + Make_Function_Call (Loc, + Name => + New_Occurrence_Of ( + RTE (RE_Caseless_String_Eq), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (RPC_Receiver_Subp_Id, Loc), + Make_String_Literal (Loc, Subp_Str))), + + Then_Statements => New_List ( + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of ( + RPC_Receiver_Subp_Index, Loc), + Expression => + Make_Integer_Literal (Loc, + Intval => Current_Primitive_Number))))); + end if; + + Append_To (RPC_Receiver_Case_Alternatives, + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => New_List ( + Make_Integer_Literal (Loc, Current_Primitive_Number)), + + Statements => New_List ( + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (Current_Receiver, Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (RPC_Receiver_Request, Loc)))))); + end if; + + -- Increment the index of current primitive + + Current_Primitive_Number := Current_Primitive_Number + 1; + end if; + + Next_Elmt (Current_Primitive_Elmt); + end loop; + end if; + + -- Build the case statement and the heart of the subprogram + + if Build_Bodies and then not Is_RAS then + if Get_PCS_Name = Name_PolyORB_DSA + and then Present (First (RPC_Receiver_Elsif_Parts)) + then + Append_To (RPC_Receiver_Statements, + Make_Implicit_If_Statement (Designated_Type, + Condition => New_Occurrence_Of (Standard_False, Loc), + Then_Statements => New_List, + Elsif_Parts => RPC_Receiver_Elsif_Parts)); + end if; + + Append_To (RPC_Receiver_Case_Alternatives, + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => New_List (Make_Others_Choice (Loc)), + Statements => New_List (Make_Null_Statement (Loc)))); + + Append_To (RPC_Receiver_Statements, + Make_Case_Statement (Loc, + Expression => + New_Occurrence_Of (RPC_Receiver_Subp_Index, Loc), + Alternatives => RPC_Receiver_Case_Alternatives)); + + Append_To (Body_Decls, RPC_Receiver_Decl); + Specific_Add_Obj_RPC_Receiver_Completion (Loc, + Body_Decls, RPC_Receiver, Stub_Elements); + + -- Do not analyze RPC receiver body at this stage since it references + -- subprograms that have not been analyzed yet. It will be analyzed in + -- the regular flow (see Append_RACW_Bodies). + + end if; + end Add_RACW_Primitive_Declarations_And_Bodies; + + ----------------------------- + -- Add_RAS_Dereference_TSS -- + ----------------------------- + + procedure Add_RAS_Dereference_TSS (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + + Type_Def : constant Node_Id := Type_Definition (N); + RAS_Type : constant Entity_Id := Defining_Identifier (N); + Fat_Type : constant Entity_Id := Equivalent_Type (RAS_Type); + RACW_Type : constant Entity_Id := Underlying_RACW_Type (RAS_Type); + + RACW_Primitive_Name : Node_Id; + + Proc : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => Make_TSS_Name (RAS_Type, TSS_RAS_Dereference)); + + Proc_Spec : Node_Id; + Param_Specs : List_Id; + Param_Assoc : constant List_Id := New_List; + Stmts : constant List_Id := New_List; + + RAS_Parameter : constant Entity_Id := Make_Temporary (Loc, 'P'); + + Is_Function : constant Boolean := + Nkind (Type_Def) = N_Access_Function_Definition; + + Is_Degenerate : Boolean; + -- Set to True if the subprogram_specification for this RAS has an + -- anonymous access parameter (see Process_Remote_AST_Declaration). + + Spec : constant Node_Id := Type_Def; + + Current_Parameter : Node_Id; + + -- Start of processing for Add_RAS_Dereference_TSS + + begin + -- The Dereference TSS for a remote access-to-subprogram type has the + -- form: + + -- [function|procedure] ras_typeRD (RAS_Value, <RAS_Parameters>) + -- [return <>] + + -- This is called whenever a value of a RAS type is dereferenced + + -- First construct a list of parameter specifications: + + -- The first formal is the RAS values + + Param_Specs := New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => RAS_Parameter, + In_Present => True, + Parameter_Type => + New_Occurrence_Of (Fat_Type, Loc))); + + -- The following formals are copied from the type declaration + + Is_Degenerate := False; + Current_Parameter := First (Parameter_Specifications (Type_Def)); + Parameters : while Present (Current_Parameter) loop + if Nkind (Parameter_Type (Current_Parameter)) = + N_Access_Definition + then + Is_Degenerate := True; + end if; + + Append_To (Param_Specs, + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, + Chars => Chars (Defining_Identifier (Current_Parameter))), + In_Present => In_Present (Current_Parameter), + Out_Present => Out_Present (Current_Parameter), + Parameter_Type => + New_Copy_Tree (Parameter_Type (Current_Parameter)), + Expression => + New_Copy_Tree (Expression (Current_Parameter)))); + + Append_To (Param_Assoc, + Make_Identifier (Loc, + Chars => Chars (Defining_Identifier (Current_Parameter)))); + + Next (Current_Parameter); + end loop Parameters; + + if Is_Degenerate then + Prepend_To (Param_Assoc, New_Occurrence_Of (RAS_Parameter, Loc)); + + -- Generate a dummy body. This code will never actually be executed, + -- because null is the only legal value for a degenerate RAS type. + -- For legality's sake (in order to avoid generating a function that + -- does not contain a return statement), we include a dummy recursive + -- call on the TSS itself. + + Append_To (Stmts, + Make_Raise_Program_Error (Loc, Reason => PE_Explicit_Raise)); + RACW_Primitive_Name := New_Occurrence_Of (Proc, Loc); + + else + -- For a normal RAS type, we cast the RAS formal to the corresponding + -- tagged type, and perform a dispatching call to its Call primitive + -- operation. + + Prepend_To (Param_Assoc, + Unchecked_Convert_To (RACW_Type, + New_Occurrence_Of (RAS_Parameter, Loc))); + + RACW_Primitive_Name := + Make_Selected_Component (Loc, + Prefix => Scope (RACW_Type), + Selector_Name => Name_uCall); + end if; + + if Is_Function then + Append_To (Stmts, + Make_Simple_Return_Statement (Loc, + Expression => + Make_Function_Call (Loc, + Name => RACW_Primitive_Name, + Parameter_Associations => Param_Assoc))); + + else + Append_To (Stmts, + Make_Procedure_Call_Statement (Loc, + Name => RACW_Primitive_Name, + Parameter_Associations => Param_Assoc)); + end if; + + -- Build the complete subprogram + + if Is_Function then + Proc_Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => Proc, + Parameter_Specifications => Param_Specs, + Result_Definition => + New_Occurrence_Of ( + Entity (Result_Definition (Spec)), Loc)); + + Set_Ekind (Proc, E_Function); + Set_Etype (Proc, + New_Occurrence_Of (Entity (Result_Definition (Spec)), Loc)); + + else + Proc_Spec := + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Proc, + Parameter_Specifications => Param_Specs); + + Set_Ekind (Proc, E_Procedure); + Set_Etype (Proc, Standard_Void_Type); + end if; + + Discard_Node ( + Make_Subprogram_Body (Loc, + Specification => Proc_Spec, + Declarations => New_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stmts))); + + Set_TSS (Fat_Type, Proc); + end Add_RAS_Dereference_TSS; + + ------------------------------- + -- Add_RAS_Proxy_And_Analyze -- + ------------------------------- + + procedure Add_RAS_Proxy_And_Analyze + (Decls : List_Id; + Vis_Decl : Node_Id; + All_Calls_Remote_E : Entity_Id; + Proxy_Object_Addr : out Entity_Id) + is + Loc : constant Source_Ptr := Sloc (Vis_Decl); + + Subp_Name : constant Entity_Id := + Defining_Unit_Name (Specification (Vis_Decl)); + + Pkg_Name : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (Subp_Name), 'P', -1)); + + Proxy_Type : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => + New_External_Name + (Related_Id => Chars (Subp_Name), + Suffix => 'P')); + + Proxy_Type_Full_View : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars (Proxy_Type)); + + Subp_Decl_Spec : constant Node_Id := + Build_RAS_Primitive_Specification + (Subp_Spec => Specification (Vis_Decl), + Remote_Object_Type => Proxy_Type); + + Subp_Body_Spec : constant Node_Id := + Build_RAS_Primitive_Specification + (Subp_Spec => Specification (Vis_Decl), + Remote_Object_Type => Proxy_Type); + + Vis_Decls : constant List_Id := New_List; + Pvt_Decls : constant List_Id := New_List; + Actuals : constant List_Id := New_List; + Formal : Node_Id; + Perform_Call : Node_Id; + + begin + -- type subpP is tagged limited private; + + Append_To (Vis_Decls, + Make_Private_Type_Declaration (Loc, + Defining_Identifier => Proxy_Type, + Tagged_Present => True, + Limited_Present => True)); + + -- [subprogram] Call + -- (Self : access subpP; + -- ...other-formals...) + -- [return T]; + + Append_To (Vis_Decls, + Make_Subprogram_Declaration (Loc, + Specification => Subp_Decl_Spec)); + + -- A : constant System.Address; + + Proxy_Object_Addr := Make_Defining_Identifier (Loc, Name_uA); + + Append_To (Vis_Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Proxy_Object_Addr, + Constant_Present => True, + Object_Definition => New_Occurrence_Of (RTE (RE_Address), Loc))); + + -- private + + -- type subpP is tagged limited record + -- All_Calls_Remote : Boolean := [All_Calls_Remote?]; + -- ... + -- end record; + + Append_To (Pvt_Decls, + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Proxy_Type_Full_View, + Type_Definition => + Build_Remote_Subprogram_Proxy_Type (Loc, + New_Occurrence_Of (All_Calls_Remote_E, Loc)))); + + -- Trick semantic analysis into swapping the public and full view when + -- freezing the public view. + + Set_Comes_From_Source (Proxy_Type_Full_View, True); + + -- procedure Call + -- (Self : access O; + -- ...other-formals...) is + -- begin + -- P (...other-formals...); + -- end Call; + + -- function Call + -- (Self : access O; + -- ...other-formals...) + -- return T is + -- begin + -- return F (...other-formals...); + -- end Call; + + if Nkind (Subp_Decl_Spec) = N_Procedure_Specification then + Perform_Call := + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (Subp_Name, Loc), + Parameter_Associations => Actuals); + else + Perform_Call := + Make_Simple_Return_Statement (Loc, + Expression => + Make_Function_Call (Loc, + Name => New_Occurrence_Of (Subp_Name, Loc), + Parameter_Associations => Actuals)); + end if; + + Formal := First (Parameter_Specifications (Subp_Decl_Spec)); + pragma Assert (Present (Formal)); + loop + Next (Formal); + exit when No (Formal); + Append_To (Actuals, + New_Occurrence_Of (Defining_Identifier (Formal), Loc)); + end loop; + + -- O : aliased subpP; + + Append_To (Pvt_Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_uO), + Aliased_Present => True, + Object_Definition => New_Occurrence_Of (Proxy_Type, Loc))); + + -- A : constant System.Address := O'Address; + + Append_To (Pvt_Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Chars (Proxy_Object_Addr)), + Constant_Present => True, + Object_Definition => New_Occurrence_Of (RTE (RE_Address), Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of ( + Defining_Identifier (Last (Pvt_Decls)), Loc), + Attribute_Name => Name_Address))); + + Append_To (Decls, + Make_Package_Declaration (Loc, + Specification => Make_Package_Specification (Loc, + Defining_Unit_Name => Pkg_Name, + Visible_Declarations => Vis_Decls, + Private_Declarations => Pvt_Decls, + End_Label => Empty))); + Analyze (Last (Decls)); + + Append_To (Decls, + Make_Package_Body (Loc, + Defining_Unit_Name => + Make_Defining_Identifier (Loc, Chars (Pkg_Name)), + Declarations => New_List ( + Make_Subprogram_Body (Loc, + Specification => Subp_Body_Spec, + Declarations => New_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Perform_Call)))))); + Analyze (Last (Decls)); + end Add_RAS_Proxy_And_Analyze; + + ----------------------- + -- Add_RAST_Features -- + ----------------------- + + procedure Add_RAST_Features (Vis_Decl : Node_Id) is + RAS_Type : constant Entity_Id := + Equivalent_Type (Defining_Identifier (Vis_Decl)); + begin + pragma Assert (No (TSS (RAS_Type, TSS_RAS_Access))); + Add_RAS_Dereference_TSS (Vis_Decl); + Specific_Add_RAST_Features (Vis_Decl, RAS_Type); + end Add_RAST_Features; + + ------------------- + -- Add_Stub_Type -- + ------------------- + + procedure Add_Stub_Type + (Designated_Type : Entity_Id; + RACW_Type : Entity_Id; + Decls : List_Id; + Stub_Type : out Entity_Id; + Stub_Type_Access : out Entity_Id; + RPC_Receiver_Decl : out Node_Id; + Body_Decls : out List_Id; + Existing : out Boolean) + is + Loc : constant Source_Ptr := Sloc (RACW_Type); + + Stub_Elements : constant Stub_Structure := + Stubs_Table.Get (Designated_Type); + Stub_Type_Decl : Node_Id; + Stub_Type_Access_Decl : Node_Id; + + begin + if Stub_Elements /= Empty_Stub_Structure then + Stub_Type := Stub_Elements.Stub_Type; + Stub_Type_Access := Stub_Elements.Stub_Type_Access; + RPC_Receiver_Decl := Stub_Elements.RPC_Receiver_Decl; + Body_Decls := Stub_Elements.Body_Decls; + Existing := True; + return; + end if; + + Existing := False; + Stub_Type := Make_Temporary (Loc, 'S'); + Set_Ekind (Stub_Type, E_Record_Type); + Set_Is_RACW_Stub_Type (Stub_Type); + Stub_Type_Access := + Make_Defining_Identifier (Loc, + Chars => New_External_Name + (Related_Id => Chars (Stub_Type), Suffix => 'A')); + + RPC_Receiver_Decl := Specific_RPC_Receiver_Decl (RACW_Type); + + -- Create new stub type, copying components from generic RACW_Stub_Type + + Stub_Type_Decl := + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Stub_Type, + Type_Definition => + Make_Record_Definition (Loc, + Tagged_Present => True, + Limited_Present => True, + Component_List => + Make_Component_List (Loc, + Component_Items => + Copy_Component_List (RTE (RE_RACW_Stub_Type), Loc)))); + + -- Does the stub type need to explicitly implement interfaces from the + -- designated type??? + + -- In particular are there issues in the case where the designated type + -- is a synchronized interface??? + + Stub_Type_Access_Decl := + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Stub_Type_Access, + Type_Definition => + Make_Access_To_Object_Definition (Loc, + All_Present => True, + Subtype_Indication => New_Occurrence_Of (Stub_Type, Loc))); + + Append_To (Decls, Stub_Type_Decl); + Analyze (Last (Decls)); + Append_To (Decls, Stub_Type_Access_Decl); + Analyze (Last (Decls)); + + -- We can't directly derive the stub type from the designated type, + -- because we don't want any components or discriminants from the real + -- type, so instead we manually fake a derivation to get an appropriate + -- dispatch table. + + Derive_Subprograms (Parent_Type => Designated_Type, + Derived_Type => Stub_Type); + + if Present (RPC_Receiver_Decl) then + Append_To (Decls, RPC_Receiver_Decl); + + else + -- Kludge, requires comment??? + + RPC_Receiver_Decl := Last (Decls); + end if; + + Body_Decls := New_List; + + Stubs_Table.Set (Designated_Type, + (Stub_Type => Stub_Type, + Stub_Type_Access => Stub_Type_Access, + RPC_Receiver_Decl => RPC_Receiver_Decl, + Body_Decls => Body_Decls, + RACW_Type => RACW_Type)); + end Add_Stub_Type; + + ------------------------ + -- Append_RACW_Bodies -- + ------------------------ + + procedure Append_RACW_Bodies (Decls : List_Id; Spec_Id : Entity_Id) is + E : Entity_Id; + + begin + E := First_Entity (Spec_Id); + while Present (E) loop + if Is_Remote_Access_To_Class_Wide_Type (E) then + Append_List_To (Decls, Get_And_Reset_RACW_Bodies (E)); + end if; + + Next_Entity (E); + end loop; + end Append_RACW_Bodies; + + ---------------------------------- + -- Assign_Subprogram_Identifier -- + ---------------------------------- + + procedure Assign_Subprogram_Identifier + (Def : Entity_Id; + Spn : Int; + Id : out String_Id) + is + N : constant Name_Id := Chars (Def); + + Overload_Order : constant Int := Overload_Counter_Table.Get (N) + 1; + + begin + Overload_Counter_Table.Set (N, Overload_Order); + + Get_Name_String (N); + + -- Homonym handling: as in Exp_Dbug, but much simpler, because the only + -- entities for which we have to generate names here need only to be + -- disambiguated within their own scope. + + if Overload_Order > 1 then + Name_Buffer (Name_Len + 1 .. Name_Len + 2) := "__"; + Name_Len := Name_Len + 2; + Add_Nat_To_Name_Buffer (Overload_Order); + end if; + + Id := String_From_Name_Buffer; + Subprogram_Identifier_Table.Set + (Def, + Subprogram_Identifiers'(Str_Identifier => Id, Int_Identifier => Spn)); + end Assign_Subprogram_Identifier; + + ------------------------------------- + -- Build_Actual_Object_Declaration -- + ------------------------------------- + + procedure Build_Actual_Object_Declaration + (Object : Entity_Id; + Etyp : Entity_Id; + Variable : Boolean; + Expr : Node_Id; + Decls : List_Id) + is + Loc : constant Source_Ptr := Sloc (Object); + + begin + -- Declare a temporary object for the actual, possibly initialized with + -- a 'Input/From_Any call. + + -- Complication arises in the case of limited types, for which such a + -- declaration is illegal in Ada 95. In that case, we first generate a + -- renaming declaration of the 'Input call, and then if needed we + -- generate an overlaid non-constant view. + + if Ada_Version <= Ada_95 + and then Is_Limited_Type (Etyp) + and then Present (Expr) + then + + -- Object : Etyp renames <func-call> + + Append_To (Decls, + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Object, + Subtype_Mark => New_Occurrence_Of (Etyp, Loc), + Name => Expr)); + + if Variable then + + -- The name defined by the renaming declaration denotes a + -- constant view; create a non-constant object at the same address + -- to be used as the actual. + + declare + Constant_Object : constant Entity_Id := + Make_Temporary (Loc, 'P'); + + begin + Set_Defining_Identifier + (Last (Decls), Constant_Object); + + -- We have an unconstrained Etyp: build the actual constrained + -- subtype for the value we just read from the stream. + + -- subtype S is <actual subtype of Constant_Object>; + + Append_To (Decls, + Build_Actual_Subtype (Etyp, + New_Occurrence_Of (Constant_Object, Loc))); + + -- Object : S; + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Object, + Object_Definition => + New_Occurrence_Of + (Defining_Identifier (Last (Decls)), Loc))); + Set_Ekind (Object, E_Variable); + + -- Suppress default initialization: + -- pragma Import (Ada, Object); + + Append_To (Decls, + Make_Pragma (Loc, + Chars => Name_Import, + Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Loc, + Chars => Name_Convention, + Expression => Make_Identifier (Loc, Name_Ada)), + Make_Pragma_Argument_Association (Loc, + Chars => Name_Entity, + Expression => New_Occurrence_Of (Object, Loc))))); + + -- for Object'Address use Constant_Object'Address; + + Append_To (Decls, + Make_Attribute_Definition_Clause (Loc, + Name => New_Occurrence_Of (Object, Loc), + Chars => Name_Address, + Expression => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Constant_Object, Loc), + Attribute_Name => Name_Address))); + end; + end if; + + else + -- General case of a regular object declaration. Object is flagged + -- constant unless it has mode out or in out, to allow the backend + -- to optimize where possible. + + -- Object : [constant] Etyp [:= <expr>]; + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Object, + Constant_Present => Present (Expr) and then not Variable, + Object_Definition => New_Occurrence_Of (Etyp, Loc), + Expression => Expr)); + + if Constant_Present (Last (Decls)) then + Set_Ekind (Object, E_Constant); + else + Set_Ekind (Object, E_Variable); + end if; + end if; + end Build_Actual_Object_Declaration; + + ------------------------------ + -- Build_Get_Unique_RP_Call -- + ------------------------------ + + function Build_Get_Unique_RP_Call + (Loc : Source_Ptr; + Pointer : Entity_Id; + Stub_Type : Entity_Id) return List_Id + is + begin + return New_List ( + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Get_Unique_Remote_Pointer), Loc), + Parameter_Associations => New_List ( + Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access), + New_Occurrence_Of (Pointer, Loc)))), + + Make_Assignment_Statement (Loc, + Name => + Make_Selected_Component (Loc, + Prefix => New_Occurrence_Of (Pointer, Loc), + Selector_Name => + New_Occurrence_Of (First_Tag_Component + (Designated_Type (Etype (Pointer))), Loc)), + Expression => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Stub_Type, Loc), + Attribute_Name => Name_Tag))); + + -- Note: The assignment to Pointer._Tag is safe here because + -- we carefully ensured that Stub_Type has exactly the same layout + -- as System.Partition_Interface.RACW_Stub_Type. + + end Build_Get_Unique_RP_Call; + + ----------------------------------- + -- Build_Ordered_Parameters_List -- + ----------------------------------- + + function Build_Ordered_Parameters_List (Spec : Node_Id) return List_Id is + Constrained_List : List_Id; + Unconstrained_List : List_Id; + Current_Parameter : Node_Id; + Ptyp : Node_Id; + + First_Parameter : Node_Id; + For_RAS : Boolean := False; + + begin + if No (Parameter_Specifications (Spec)) then + return New_List; + end if; + + Constrained_List := New_List; + Unconstrained_List := New_List; + First_Parameter := First (Parameter_Specifications (Spec)); + + if Nkind (Parameter_Type (First_Parameter)) = N_Access_Definition + and then Chars (Defining_Identifier (First_Parameter)) = Name_uS + then + For_RAS := True; + end if; + + -- Loop through the parameters and add them to the right list. Note that + -- we treat a parameter of a null-excluding access type as unconstrained + -- because we can't declare an object of such a type with default + -- initialization. + + Current_Parameter := First_Parameter; + while Present (Current_Parameter) loop + Ptyp := Parameter_Type (Current_Parameter); + + if (Nkind (Ptyp) = N_Access_Definition + or else not Transmit_As_Unconstrained (Etype (Ptyp))) + and then not (For_RAS and then Current_Parameter = First_Parameter) + then + Append_To (Constrained_List, New_Copy (Current_Parameter)); + else + Append_To (Unconstrained_List, New_Copy (Current_Parameter)); + end if; + + Next (Current_Parameter); + end loop; + + -- Unconstrained parameters are returned first + + Append_List_To (Unconstrained_List, Constrained_List); + + return Unconstrained_List; + end Build_Ordered_Parameters_List; + + ---------------------------------- + -- Build_Passive_Partition_Stub -- + ---------------------------------- + + procedure Build_Passive_Partition_Stub (U : Node_Id) is + Pkg_Spec : Node_Id; + Pkg_Name : String_Id; + L : List_Id; + Reg : Node_Id; + Loc : constant Source_Ptr := Sloc (U); + + begin + -- Verify that the implementation supports distribution, by accessing + -- a type defined in the proper version of system.rpc + + declare + Dist_OK : Entity_Id; + pragma Warnings (Off, Dist_OK); + begin + Dist_OK := RTE (RE_Params_Stream_Type); + end; + + -- Use body if present, spec otherwise + + if Nkind (U) = N_Package_Declaration then + Pkg_Spec := Specification (U); + L := Visible_Declarations (Pkg_Spec); + else + Pkg_Spec := Parent (Corresponding_Spec (U)); + L := Declarations (U); + end if; + + Get_Library_Unit_Name_String (Pkg_Spec); + Pkg_Name := String_From_Name_Buffer; + Reg := + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Register_Passive_Package), Loc), + Parameter_Associations => New_List ( + Make_String_Literal (Loc, Pkg_Name), + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc), + Attribute_Name => Name_Version))); + Append_To (L, Reg); + Analyze (Reg); + end Build_Passive_Partition_Stub; + + -------------------------------------- + -- Build_RPC_Receiver_Specification -- + -------------------------------------- + + function Build_RPC_Receiver_Specification + (RPC_Receiver : Entity_Id; + Request_Parameter : Entity_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (RPC_Receiver); + begin + return + Make_Procedure_Specification (Loc, + Defining_Unit_Name => RPC_Receiver, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Request_Parameter, + Parameter_Type => + New_Occurrence_Of (RTE (RE_Request_Access), Loc)))); + end Build_RPC_Receiver_Specification; + + ---------------------------------------- + -- Build_Remote_Subprogram_Proxy_Type -- + ---------------------------------------- + + function Build_Remote_Subprogram_Proxy_Type + (Loc : Source_Ptr; + ACR_Expression : Node_Id) return Node_Id + is + begin + return + Make_Record_Definition (Loc, + Tagged_Present => True, + Limited_Present => True, + Component_List => + Make_Component_List (Loc, + Component_Items => New_List ( + Make_Component_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, + Name_All_Calls_Remote), + Component_Definition => + Make_Component_Definition (Loc, + Subtype_Indication => + New_Occurrence_Of (Standard_Boolean, Loc)), + Expression => + ACR_Expression), + + Make_Component_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, + Name_Receiver), + Component_Definition => + Make_Component_Definition (Loc, + Subtype_Indication => + New_Occurrence_Of (RTE (RE_Address), Loc)), + Expression => + New_Occurrence_Of (RTE (RE_Null_Address), Loc)), + + Make_Component_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, + Name_Subp_Id), + Component_Definition => + Make_Component_Definition (Loc, + Subtype_Indication => + New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc)))))); + end Build_Remote_Subprogram_Proxy_Type; + + -------------------- + -- Build_Stub_Tag -- + -------------------- + + function Build_Stub_Tag + (Loc : Source_Ptr; + RACW_Type : Entity_Id) return Node_Id + is + Stub_Type : constant Entity_Id := Corresponding_Stub_Type (RACW_Type); + begin + return + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Stub_Type, Loc), + Attribute_Name => Name_Tag); + end Build_Stub_Tag; + + ------------------------------------ + -- Build_Subprogram_Calling_Stubs -- + ------------------------------------ + + function Build_Subprogram_Calling_Stubs + (Vis_Decl : Node_Id; + Subp_Id : Node_Id; + Asynchronous : Boolean; + Dynamically_Asynchronous : Boolean := False; + Stub_Type : Entity_Id := Empty; + RACW_Type : Entity_Id := Empty; + Locator : Entity_Id := Empty; + New_Name : Name_Id := No_Name) return Node_Id + is + Loc : constant Source_Ptr := Sloc (Vis_Decl); + + Decls : constant List_Id := New_List; + Statements : constant List_Id := New_List; + + Subp_Spec : Node_Id; + -- The specification of the body + + Controlling_Parameter : Entity_Id := Empty; + + Asynchronous_Expr : Node_Id := Empty; + + RCI_Locator : Entity_Id; + + Spec_To_Use : Node_Id; + + procedure Insert_Partition_Check (Parameter : Node_Id); + -- Check that the parameter has been elaborated on the same partition + -- than the controlling parameter (E.4(19)). + + ---------------------------- + -- Insert_Partition_Check -- + ---------------------------- + + procedure Insert_Partition_Check (Parameter : Node_Id) is + Parameter_Entity : constant Entity_Id := + Defining_Identifier (Parameter); + begin + -- The expression that will be built is of the form: + + -- if not Same_Partition (Parameter, Controlling_Parameter) then + -- raise Constraint_Error; + -- end if; + + -- We do not check that Parameter is in Stub_Type since such a check + -- has been inserted at the point of call already (a tag check since + -- we have multiple controlling operands). + + Append_To (Decls, + Make_Raise_Constraint_Error (Loc, + Condition => + Make_Op_Not (Loc, + Right_Opnd => + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (RTE (RE_Same_Partition), Loc), + Parameter_Associations => + New_List ( + Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access), + New_Occurrence_Of (Parameter_Entity, Loc)), + Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access), + New_Occurrence_Of (Controlling_Parameter, Loc))))), + Reason => CE_Partition_Check_Failed)); + end Insert_Partition_Check; + + -- Start of processing for Build_Subprogram_Calling_Stubs + + begin + Subp_Spec := + Copy_Specification (Loc, + Spec => Specification (Vis_Decl), + New_Name => New_Name); + + if Locator = Empty then + RCI_Locator := RCI_Cache; + Spec_To_Use := Specification (Vis_Decl); + else + RCI_Locator := Locator; + Spec_To_Use := Subp_Spec; + end if; + + -- Find a controlling argument if we have a stub type. Also check + -- if this subprogram can be made asynchronous. + + if Present (Stub_Type) + and then Present (Parameter_Specifications (Spec_To_Use)) + then + declare + Current_Parameter : Node_Id := + First (Parameter_Specifications + (Spec_To_Use)); + begin + while Present (Current_Parameter) loop + if + Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type) + then + if Controlling_Parameter = Empty then + Controlling_Parameter := + Defining_Identifier (Current_Parameter); + else + Insert_Partition_Check (Current_Parameter); + end if; + end if; + + Next (Current_Parameter); + end loop; + end; + end if; + + pragma Assert (No (Stub_Type) or else Present (Controlling_Parameter)); + + if Dynamically_Asynchronous then + Asynchronous_Expr := Make_Selected_Component (Loc, + Prefix => Controlling_Parameter, + Selector_Name => Name_Asynchronous); + end if; + + Specific_Build_General_Calling_Stubs + (Decls => Decls, + Statements => Statements, + Target => Specific_Build_Stub_Target (Loc, + Decls, RCI_Locator, Controlling_Parameter), + Subprogram_Id => Subp_Id, + Asynchronous => Asynchronous_Expr, + Is_Known_Asynchronous => Asynchronous + and then not Dynamically_Asynchronous, + Is_Known_Non_Asynchronous + => not Asynchronous + and then not Dynamically_Asynchronous, + Is_Function => Nkind (Spec_To_Use) = + N_Function_Specification, + Spec => Spec_To_Use, + Stub_Type => Stub_Type, + RACW_Type => RACW_Type, + Nod => Vis_Decl); + + RCI_Calling_Stubs_Table.Set + (Defining_Unit_Name (Specification (Vis_Decl)), + Defining_Unit_Name (Spec_To_Use)); + + return + Make_Subprogram_Body (Loc, + Specification => Subp_Spec, + Declarations => Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, Statements)); + end Build_Subprogram_Calling_Stubs; + + ------------------------- + -- Build_Subprogram_Id -- + ------------------------- + + function Build_Subprogram_Id + (Loc : Source_Ptr; + E : Entity_Id) return Node_Id + is + begin + if Get_Subprogram_Ids (E).Str_Identifier = No_String then + declare + Current_Declaration : Node_Id; + Current_Subp : Entity_Id; + Current_Subp_Str : String_Id; + Current_Subp_Number : Int := First_RCI_Subprogram_Id; + + pragma Warnings (Off, Current_Subp_Str); + + begin + -- Build_Subprogram_Id is called outside of the context of + -- generating calling or receiving stubs. Hence we are processing + -- an 'Access attribute_reference for an RCI subprogram, for the + -- purpose of obtaining a RAS value. + + pragma Assert + (Is_Remote_Call_Interface (Scope (E)) + and then + (Nkind (Parent (E)) = N_Procedure_Specification + or else + Nkind (Parent (E)) = N_Function_Specification)); + + Current_Declaration := + First (Visible_Declarations + (Package_Specification_Of_Scope (Scope (E)))); + while Present (Current_Declaration) loop + if Nkind (Current_Declaration) = N_Subprogram_Declaration + and then Comes_From_Source (Current_Declaration) + then + Current_Subp := Defining_Unit_Name (Specification ( + Current_Declaration)); + + Assign_Subprogram_Identifier + (Current_Subp, Current_Subp_Number, Current_Subp_Str); + + Current_Subp_Number := Current_Subp_Number + 1; + end if; + + Next (Current_Declaration); + end loop; + end; + end if; + + case Get_PCS_Name is + when Name_PolyORB_DSA => + return Make_String_Literal (Loc, Get_Subprogram_Id (E)); + when others => + return Make_Integer_Literal (Loc, Get_Subprogram_Id (E)); + end case; + end Build_Subprogram_Id; + + ------------------------ + -- Copy_Specification -- + ------------------------ + + function Copy_Specification + (Loc : Source_Ptr; + Spec : Node_Id; + Ctrl_Type : Entity_Id := Empty; + New_Name : Name_Id := No_Name) return Node_Id + is + Parameters : List_Id := No_List; + + Current_Parameter : Node_Id; + Current_Identifier : Entity_Id; + Current_Type : Node_Id; + + Name_For_New_Spec : Name_Id; + + New_Identifier : Entity_Id; + + -- Comments needed in body below ??? + + begin + if New_Name = No_Name then + pragma Assert (Nkind (Spec) = N_Function_Specification + or else Nkind (Spec) = N_Procedure_Specification); + + Name_For_New_Spec := Chars (Defining_Unit_Name (Spec)); + else + Name_For_New_Spec := New_Name; + end if; + + if Present (Parameter_Specifications (Spec)) then + Parameters := New_List; + Current_Parameter := First (Parameter_Specifications (Spec)); + while Present (Current_Parameter) loop + Current_Identifier := Defining_Identifier (Current_Parameter); + Current_Type := Parameter_Type (Current_Parameter); + + if Nkind (Current_Type) = N_Access_Definition then + if Present (Ctrl_Type) then + pragma Assert (Is_Controlling_Formal (Current_Identifier)); + Current_Type := + Make_Access_Definition (Loc, + Subtype_Mark => New_Occurrence_Of (Ctrl_Type, Loc), + Null_Exclusion_Present => + Null_Exclusion_Present (Current_Type)); + + else + Current_Type := + Make_Access_Definition (Loc, + Subtype_Mark => + New_Copy_Tree (Subtype_Mark (Current_Type)), + Null_Exclusion_Present => + Null_Exclusion_Present (Current_Type)); + end if; + + else + if Present (Ctrl_Type) + and then Is_Controlling_Formal (Current_Identifier) + then + Current_Type := New_Occurrence_Of (Ctrl_Type, Loc); + else + Current_Type := New_Copy_Tree (Current_Type); + end if; + end if; + + New_Identifier := Make_Defining_Identifier (Loc, + Chars (Current_Identifier)); + + Append_To (Parameters, + Make_Parameter_Specification (Loc, + Defining_Identifier => New_Identifier, + Parameter_Type => Current_Type, + In_Present => In_Present (Current_Parameter), + Out_Present => Out_Present (Current_Parameter), + Expression => + New_Copy_Tree (Expression (Current_Parameter)))); + + -- For a regular formal parameter (that needs to be marshalled + -- in the context of remote calls), set the Etype now, because + -- marshalling processing might need it. + + if Is_Entity_Name (Current_Type) then + Set_Etype (New_Identifier, Entity (Current_Type)); + + -- Current_Type is an access definition, special processing + -- (not requiring etype) will occur for marshalling. + + else + null; + end if; + + Next (Current_Parameter); + end loop; + end if; + + case Nkind (Spec) is + + when N_Function_Specification | N_Access_Function_Definition => + return + Make_Function_Specification (Loc, + Defining_Unit_Name => + Make_Defining_Identifier (Loc, + Chars => Name_For_New_Spec), + Parameter_Specifications => Parameters, + Result_Definition => + New_Occurrence_Of (Entity (Result_Definition (Spec)), Loc)); + + when N_Procedure_Specification | N_Access_Procedure_Definition => + return + Make_Procedure_Specification (Loc, + Defining_Unit_Name => + Make_Defining_Identifier (Loc, + Chars => Name_For_New_Spec), + Parameter_Specifications => Parameters); + + when others => + raise Program_Error; + end case; + end Copy_Specification; + + ----------------------------- + -- Corresponding_Stub_Type -- + ----------------------------- + + function Corresponding_Stub_Type (RACW_Type : Entity_Id) return Entity_Id is + Desig : constant Entity_Id := + Etype (Designated_Type (RACW_Type)); + Stub_Elements : constant Stub_Structure := Stubs_Table.Get (Desig); + begin + return Stub_Elements.Stub_Type; + end Corresponding_Stub_Type; + + --------------------------- + -- Could_Be_Asynchronous -- + --------------------------- + + function Could_Be_Asynchronous (Spec : Node_Id) return Boolean is + Current_Parameter : Node_Id; + + begin + if Present (Parameter_Specifications (Spec)) then + Current_Parameter := First (Parameter_Specifications (Spec)); + while Present (Current_Parameter) loop + if Out_Present (Current_Parameter) then + return False; + end if; + + Next (Current_Parameter); + end loop; + end if; + + return True; + end Could_Be_Asynchronous; + + --------------------------- + -- Declare_Create_NVList -- + --------------------------- + + procedure Declare_Create_NVList + (Loc : Source_Ptr; + NVList : Entity_Id; + Decls : List_Id; + Stmts : List_Id) + is + begin + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => NVList, + Aliased_Present => False, + Object_Definition => + New_Occurrence_Of (RTE (RE_NVList_Ref), Loc))); + + Append_To (Stmts, + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (RTE (RE_NVList_Create), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (NVList, Loc)))); + end Declare_Create_NVList; + + --------------------------------------------- + -- Expand_All_Calls_Remote_Subprogram_Call -- + --------------------------------------------- + + procedure Expand_All_Calls_Remote_Subprogram_Call (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Called_Subprogram : constant Entity_Id := Entity (Name (N)); + RCI_Package : constant Entity_Id := Scope (Called_Subprogram); + RCI_Locator_Decl : Node_Id; + RCI_Locator : Entity_Id; + Calling_Stubs : Node_Id; + E_Calling_Stubs : Entity_Id; + + begin + E_Calling_Stubs := RCI_Calling_Stubs_Table.Get (Called_Subprogram); + + if E_Calling_Stubs = Empty then + RCI_Locator := RCI_Locator_Table.Get (RCI_Package); + + -- The RCI_Locator package and calling stub are is inserted at the + -- top level in the current unit, and must appear in the proper scope + -- so that it is not prematurely removed by the GCC back end. + + declare + Scop : constant Entity_Id := Cunit_Entity (Current_Sem_Unit); + begin + if Ekind (Scop) = E_Package_Body then + Push_Scope (Spec_Entity (Scop)); + elsif Ekind (Scop) = E_Subprogram_Body then + Push_Scope + (Corresponding_Spec (Unit_Declaration_Node (Scop))); + else + Push_Scope (Scop); + end if; + end; + + if RCI_Locator = Empty then + RCI_Locator_Decl := + RCI_Package_Locator + (Loc, Specification (Unit_Declaration_Node (RCI_Package))); + Prepend_To (Current_Sem_Unit_Declarations, RCI_Locator_Decl); + Analyze (RCI_Locator_Decl); + RCI_Locator := Defining_Unit_Name (RCI_Locator_Decl); + + else + RCI_Locator_Decl := Parent (RCI_Locator); + end if; + + Calling_Stubs := Build_Subprogram_Calling_Stubs + (Vis_Decl => Parent (Parent (Called_Subprogram)), + Subp_Id => + Build_Subprogram_Id (Loc, Called_Subprogram), + Asynchronous => Nkind (N) = N_Procedure_Call_Statement + and then + Is_Asynchronous (Called_Subprogram), + Locator => RCI_Locator, + New_Name => New_Internal_Name ('S')); + Insert_After (RCI_Locator_Decl, Calling_Stubs); + Analyze (Calling_Stubs); + Pop_Scope; + + E_Calling_Stubs := Defining_Unit_Name (Specification (Calling_Stubs)); + end if; + + Rewrite (Name (N), New_Occurrence_Of (E_Calling_Stubs, Loc)); + end Expand_All_Calls_Remote_Subprogram_Call; + + --------------------------------- + -- Expand_Calling_Stubs_Bodies -- + --------------------------------- + + procedure Expand_Calling_Stubs_Bodies (Unit_Node : Node_Id) is + Spec : constant Node_Id := Specification (Unit_Node); + begin + Add_Calling_Stubs_To_Declarations (Spec); + end Expand_Calling_Stubs_Bodies; + + ----------------------------------- + -- Expand_Receiving_Stubs_Bodies -- + ----------------------------------- + + procedure Expand_Receiving_Stubs_Bodies (Unit_Node : Node_Id) is + Spec : Node_Id; + Decls : List_Id; + Stubs_Decls : List_Id; + Stubs_Stmts : List_Id; + + begin + if Nkind (Unit_Node) = N_Package_Declaration then + Spec := Specification (Unit_Node); + Decls := Private_Declarations (Spec); + + if No (Decls) then + Decls := Visible_Declarations (Spec); + end if; + + Push_Scope (Scope_Of_Spec (Spec)); + Specific_Add_Receiving_Stubs_To_Declarations (Spec, Decls, Decls); + + else + Spec := + Package_Specification_Of_Scope (Corresponding_Spec (Unit_Node)); + Decls := Declarations (Unit_Node); + + Push_Scope (Scope_Of_Spec (Unit_Node)); + Stubs_Decls := New_List; + Stubs_Stmts := New_List; + Specific_Add_Receiving_Stubs_To_Declarations + (Spec, Stubs_Decls, Stubs_Stmts); + + Insert_List_Before (First (Decls), Stubs_Decls); + + declare + HSS_Stmts : constant List_Id := + Statements (Handled_Statement_Sequence (Unit_Node)); + + First_HSS_Stmt : constant Node_Id := First (HSS_Stmts); + + begin + if No (First_HSS_Stmt) then + Append_List_To (HSS_Stmts, Stubs_Stmts); + else + Insert_List_Before (First_HSS_Stmt, Stubs_Stmts); + end if; + end; + end if; + + Pop_Scope; + end Expand_Receiving_Stubs_Bodies; + + -------------------- + -- GARLIC_Support -- + -------------------- + + package body GARLIC_Support is + + -- Local subprograms + + procedure Add_RACW_Read_Attribute + (RACW_Type : Entity_Id; + Stub_Type : Entity_Id; + Stub_Type_Access : Entity_Id; + Body_Decls : List_Id); + -- Add Read attribute for the RACW type. The declaration and attribute + -- definition clauses are inserted right after the declaration of + -- RACW_Type. If Body_Decls is not No_List, the subprogram body is + -- appended to it (case where the RACW declaration is in the main unit). + + procedure Add_RACW_Write_Attribute + (RACW_Type : Entity_Id; + Stub_Type : Entity_Id; + Stub_Type_Access : Entity_Id; + RPC_Receiver : Node_Id; + Body_Decls : List_Id); + -- Same as above for the Write attribute + + function Stream_Parameter return Node_Id; + function Result return Node_Id; + function Object return Node_Id renames Result; + -- Functions to create occurrences of the formal parameter names of the + -- 'Read and 'Write attributes. + + Loc : Source_Ptr; + -- Shared source location used by Add_{Read,Write}_Read_Attribute and + -- their ancillary subroutines (set on entry by Add_RACW_Features). + + procedure Add_RAS_Access_TSS (N : Node_Id); + -- Add a subprogram body for RAS Access TSS + + ------------------------------------- + -- Add_Obj_RPC_Receiver_Completion -- + ------------------------------------- + + procedure Add_Obj_RPC_Receiver_Completion + (Loc : Source_Ptr; + Decls : List_Id; + RPC_Receiver : Entity_Id; + Stub_Elements : Stub_Structure) + is + begin + -- The RPC receiver body should not be the completion of the + -- declaration recorded in the stub structure, because then the + -- occurrences of the formal parameters within the body should refer + -- to the entities from the declaration, not from the completion, to + -- which we do not have easy access. Instead, the RPC receiver body + -- acts as its own declaration, and the RPC receiver declaration is + -- completed by a renaming-as-body. + + Append_To (Decls, + Make_Subprogram_Renaming_Declaration (Loc, + Specification => + Copy_Specification (Loc, + Specification (Stub_Elements.RPC_Receiver_Decl)), + Name => New_Occurrence_Of (RPC_Receiver, Loc))); + end Add_Obj_RPC_Receiver_Completion; + + ----------------------- + -- Add_RACW_Features -- + ----------------------- + + procedure Add_RACW_Features + (RACW_Type : Entity_Id; + Stub_Type : Entity_Id; + Stub_Type_Access : Entity_Id; + RPC_Receiver_Decl : Node_Id; + Body_Decls : List_Id) + is + RPC_Receiver : Node_Id; + Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type); + + begin + Loc := Sloc (RACW_Type); + + if Is_RAS then + + -- For a RAS, the RPC receiver is that of the RCI unit, not that + -- of the corresponding distributed object type. We retrieve its + -- address from the local proxy object. + + RPC_Receiver := Make_Selected_Component (Loc, + Prefix => + Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access), Object), + Selector_Name => Make_Identifier (Loc, Name_Receiver)); + + else + RPC_Receiver := Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of ( + Defining_Unit_Name (Specification (RPC_Receiver_Decl)), Loc), + Attribute_Name => Name_Address); + end if; + + Add_RACW_Write_Attribute + (RACW_Type, + Stub_Type, + Stub_Type_Access, + RPC_Receiver, + Body_Decls); + + Add_RACW_Read_Attribute + (RACW_Type, + Stub_Type, + Stub_Type_Access, + Body_Decls); + end Add_RACW_Features; + + ----------------------------- + -- Add_RACW_Read_Attribute -- + ----------------------------- + + procedure Add_RACW_Read_Attribute + (RACW_Type : Entity_Id; + Stub_Type : Entity_Id; + Stub_Type_Access : Entity_Id; + Body_Decls : List_Id) + is + Proc_Decl : Node_Id; + Attr_Decl : Node_Id; + + Body_Node : Node_Id; + + Statements : constant List_Id := New_List; + Decls : List_Id; + Local_Statements : List_Id; + Remote_Statements : List_Id; + -- Various parts of the procedure + + Pnam : constant Entity_Id := Make_Temporary (Loc, 'R'); + Asynchronous_Flag : constant Entity_Id := + Asynchronous_Flags_Table.Get (RACW_Type); + pragma Assert (Present (Asynchronous_Flag)); + + -- Prepare local identifiers + + Source_Partition : Entity_Id; + Source_Receiver : Entity_Id; + Source_Address : Entity_Id; + Local_Stub : Entity_Id; + Stubbed_Result : Entity_Id; + + -- Start of processing for Add_RACW_Read_Attribute + + begin + Build_Stream_Procedure (Loc, + RACW_Type, Body_Node, Pnam, Statements, Outp => True); + Proc_Decl := Make_Subprogram_Declaration (Loc, + Copy_Specification (Loc, Specification (Body_Node))); + + Attr_Decl := + Make_Attribute_Definition_Clause (Loc, + Name => New_Occurrence_Of (RACW_Type, Loc), + Chars => Name_Read, + Expression => + New_Occurrence_Of ( + Defining_Unit_Name (Specification (Proc_Decl)), Loc)); + + Insert_After (Declaration_Node (RACW_Type), Proc_Decl); + Insert_After (Proc_Decl, Attr_Decl); + + if No (Body_Decls) then + + -- Case of processing an RACW type from another unit than the + -- main one: do not generate a body. + + return; + end if; + + -- Prepare local identifiers + + Source_Partition := Make_Temporary (Loc, 'P'); + Source_Receiver := Make_Temporary (Loc, 'S'); + Source_Address := Make_Temporary (Loc, 'P'); + Local_Stub := Make_Temporary (Loc, 'L'); + Stubbed_Result := Make_Temporary (Loc, 'S'); + + -- Generate object declarations + + Decls := New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => Source_Partition, + Object_Definition => + New_Occurrence_Of (RTE (RE_Partition_ID), Loc)), + + Make_Object_Declaration (Loc, + Defining_Identifier => Source_Receiver, + Object_Definition => + New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)), + + Make_Object_Declaration (Loc, + Defining_Identifier => Source_Address, + Object_Definition => + New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)), + + Make_Object_Declaration (Loc, + Defining_Identifier => Local_Stub, + Aliased_Present => True, + Object_Definition => New_Occurrence_Of (Stub_Type, Loc)), + + Make_Object_Declaration (Loc, + Defining_Identifier => Stubbed_Result, + Object_Definition => + New_Occurrence_Of (Stub_Type_Access, Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Local_Stub, Loc), + Attribute_Name => + Name_Unchecked_Access))); + + -- Read the source Partition_ID and RPC_Receiver from incoming stream + + Append_List_To (Statements, New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (RTE (RE_Partition_ID), Loc), + Attribute_Name => Name_Read, + Expressions => New_List ( + Stream_Parameter, + New_Occurrence_Of (Source_Partition, Loc))), + + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (RTE (RE_Unsigned_64), Loc), + Attribute_Name => + Name_Read, + Expressions => New_List ( + Stream_Parameter, + New_Occurrence_Of (Source_Receiver, Loc))), + + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (RTE (RE_Unsigned_64), Loc), + Attribute_Name => + Name_Read, + Expressions => New_List ( + Stream_Parameter, + New_Occurrence_Of (Source_Address, Loc))))); + + -- Build_Get_Unique_RP_Call needs the type of Stubbed_Result + + Set_Etype (Stubbed_Result, Stub_Type_Access); + + -- If the Address is Null_Address, then return a null object, unless + -- RACW_Type is null-excluding, in which case unconditionally raise + -- CONSTRAINT_ERROR instead. + + declare + Zero_Statements : List_Id; + -- Statements executed when a zero value is received + + begin + if Can_Never_Be_Null (RACW_Type) then + Zero_Statements := New_List ( + Make_Raise_Constraint_Error (Loc, + Reason => CE_Null_Not_Allowed)); + else + Zero_Statements := New_List ( + Make_Assignment_Statement (Loc, + Name => Result, + Expression => Make_Null (Loc)), + Make_Simple_Return_Statement (Loc)); + end if; + + Append_To (Statements, + Make_Implicit_If_Statement (RACW_Type, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => New_Occurrence_Of (Source_Address, Loc), + Right_Opnd => Make_Integer_Literal (Loc, Uint_0)), + Then_Statements => Zero_Statements)); + end; + + -- If the RACW denotes an object created on the current partition, + -- Local_Statements will be executed. The real object will be used. + + Local_Statements := New_List ( + Make_Assignment_Statement (Loc, + Name => Result, + Expression => + Unchecked_Convert_To (RACW_Type, + OK_Convert_To (RTE (RE_Address), + New_Occurrence_Of (Source_Address, Loc))))); + + -- If the object is located on another partition, then a stub object + -- will be created with all the information needed to rebuild the + -- real object at the other end. + + Remote_Statements := New_List ( + + Make_Assignment_Statement (Loc, + Name => Make_Selected_Component (Loc, + Prefix => Stubbed_Result, + Selector_Name => Name_Origin), + Expression => + New_Occurrence_Of (Source_Partition, Loc)), + + Make_Assignment_Statement (Loc, + Name => Make_Selected_Component (Loc, + Prefix => Stubbed_Result, + Selector_Name => Name_Receiver), + Expression => + New_Occurrence_Of (Source_Receiver, Loc)), + + Make_Assignment_Statement (Loc, + Name => Make_Selected_Component (Loc, + Prefix => Stubbed_Result, + Selector_Name => Name_Addr), + Expression => + New_Occurrence_Of (Source_Address, Loc))); + + Append_To (Remote_Statements, + Make_Assignment_Statement (Loc, + Name => Make_Selected_Component (Loc, + Prefix => Stubbed_Result, + Selector_Name => Name_Asynchronous), + Expression => + New_Occurrence_Of (Asynchronous_Flag, Loc))); + + Append_List_To (Remote_Statements, + Build_Get_Unique_RP_Call (Loc, Stubbed_Result, Stub_Type)); + -- ??? Issue with asynchronous calls here: the Asynchronous flag is + -- set on the stub type if, and only if, the RACW type has a pragma + -- Asynchronous. This is incorrect for RACWs that implement RAS + -- types, because in that case the /designated subprogram/ (not the + -- type) might be asynchronous, and that causes the stub to need to + -- be asynchronous too. A solution is to transport a RAS as a struct + -- containing a RACW and an asynchronous flag, and to properly alter + -- the Asynchronous component in the stub type in the RAS's Input + -- TSS. + + Append_To (Remote_Statements, + Make_Assignment_Statement (Loc, + Name => Result, + Expression => Unchecked_Convert_To (RACW_Type, + New_Occurrence_Of (Stubbed_Result, Loc)))); + + -- Distinguish between the local and remote cases, and execute the + -- appropriate piece of code. + + Append_To (Statements, + Make_Implicit_If_Statement (RACW_Type, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => + Make_Function_Call (Loc, + Name => New_Occurrence_Of ( + RTE (RE_Get_Local_Partition_Id), Loc)), + Right_Opnd => New_Occurrence_Of (Source_Partition, Loc)), + Then_Statements => Local_Statements, + Else_Statements => Remote_Statements)); + + Set_Declarations (Body_Node, Decls); + Append_To (Body_Decls, Body_Node); + end Add_RACW_Read_Attribute; + + ------------------------------ + -- Add_RACW_Write_Attribute -- + ------------------------------ + + procedure Add_RACW_Write_Attribute + (RACW_Type : Entity_Id; + Stub_Type : Entity_Id; + Stub_Type_Access : Entity_Id; + RPC_Receiver : Node_Id; + Body_Decls : List_Id) + is + Body_Node : Node_Id; + Proc_Decl : Node_Id; + Attr_Decl : Node_Id; + + Statements : constant List_Id := New_List; + Local_Statements : List_Id; + Remote_Statements : List_Id; + Null_Statements : List_Id; + + Pnam : constant Entity_Id := Make_Temporary (Loc, 'R'); + + begin + Build_Stream_Procedure + (Loc, RACW_Type, Body_Node, Pnam, Statements, Outp => False); + + Proc_Decl := Make_Subprogram_Declaration (Loc, + Copy_Specification (Loc, Specification (Body_Node))); + + Attr_Decl := + Make_Attribute_Definition_Clause (Loc, + Name => New_Occurrence_Of (RACW_Type, Loc), + Chars => Name_Write, + Expression => + New_Occurrence_Of ( + Defining_Unit_Name (Specification (Proc_Decl)), Loc)); + + Insert_After (Declaration_Node (RACW_Type), Proc_Decl); + Insert_After (Proc_Decl, Attr_Decl); + + if No (Body_Decls) then + return; + end if; + + -- Build the code fragment corresponding to the marshalling of a + -- local object. + + Local_Statements := New_List ( + + Pack_Entity_Into_Stream_Access (Loc, + Stream => Stream_Parameter, + Object => RTE (RE_Get_Local_Partition_Id)), + + Pack_Node_Into_Stream_Access (Loc, + Stream => Stream_Parameter, + Object => OK_Convert_To (RTE (RE_Unsigned_64), RPC_Receiver), + Etyp => RTE (RE_Unsigned_64)), + + Pack_Node_Into_Stream_Access (Loc, + Stream => Stream_Parameter, + Object => OK_Convert_To (RTE (RE_Unsigned_64), + Make_Attribute_Reference (Loc, + Prefix => + Make_Explicit_Dereference (Loc, + Prefix => Object), + Attribute_Name => Name_Address)), + Etyp => RTE (RE_Unsigned_64))); + + -- Build the code fragment corresponding to the marshalling of + -- a remote object. + + Remote_Statements := New_List ( + Pack_Node_Into_Stream_Access (Loc, + Stream => Stream_Parameter, + Object => + Make_Selected_Component (Loc, + Prefix => + Unchecked_Convert_To (Stub_Type_Access, Object), + Selector_Name => Make_Identifier (Loc, Name_Origin)), + Etyp => RTE (RE_Partition_ID)), + + Pack_Node_Into_Stream_Access (Loc, + Stream => Stream_Parameter, + Object => + Make_Selected_Component (Loc, + Prefix => + Unchecked_Convert_To (Stub_Type_Access, Object), + Selector_Name => Make_Identifier (Loc, Name_Receiver)), + Etyp => RTE (RE_Unsigned_64)), + + Pack_Node_Into_Stream_Access (Loc, + Stream => Stream_Parameter, + Object => + Make_Selected_Component (Loc, + Prefix => + Unchecked_Convert_To (Stub_Type_Access, Object), + Selector_Name => Make_Identifier (Loc, Name_Addr)), + Etyp => RTE (RE_Unsigned_64))); + + -- Build code fragment corresponding to marshalling of a null object + + Null_Statements := New_List ( + + Pack_Entity_Into_Stream_Access (Loc, + Stream => Stream_Parameter, + Object => RTE (RE_Get_Local_Partition_Id)), + + Pack_Node_Into_Stream_Access (Loc, + Stream => Stream_Parameter, + Object => OK_Convert_To (RTE (RE_Unsigned_64), RPC_Receiver), + Etyp => RTE (RE_Unsigned_64)), + + Pack_Node_Into_Stream_Access (Loc, + Stream => Stream_Parameter, + Object => Make_Integer_Literal (Loc, Uint_0), + Etyp => RTE (RE_Unsigned_64))); + + Append_To (Statements, + Make_Implicit_If_Statement (RACW_Type, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => Object, + Right_Opnd => Make_Null (Loc)), + + Then_Statements => Null_Statements, + + Elsif_Parts => New_List ( + Make_Elsif_Part (Loc, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => + Make_Attribute_Reference (Loc, + Prefix => Object, + Attribute_Name => Name_Tag), + + Right_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Stub_Type, Loc), + Attribute_Name => Name_Tag)), + Then_Statements => Remote_Statements)), + Else_Statements => Local_Statements)); + + Append_To (Body_Decls, Body_Node); + end Add_RACW_Write_Attribute; + + ------------------------ + -- Add_RAS_Access_TSS -- + ------------------------ + + procedure Add_RAS_Access_TSS (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + + Ras_Type : constant Entity_Id := Defining_Identifier (N); + Fat_Type : constant Entity_Id := Equivalent_Type (Ras_Type); + -- Ras_Type is the access to subprogram type while Fat_Type is the + -- corresponding record type. + + RACW_Type : constant Entity_Id := + Underlying_RACW_Type (Ras_Type); + Desig : constant Entity_Id := + Etype (Designated_Type (RACW_Type)); + + Stub_Elements : constant Stub_Structure := + Stubs_Table.Get (Desig); + pragma Assert (Stub_Elements /= Empty_Stub_Structure); + + Proc : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => Make_TSS_Name (Ras_Type, TSS_RAS_Access)); + + Proc_Spec : Node_Id; + + -- Formal parameters + + Package_Name : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => Name_P); + -- Target package + + Subp_Id : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => Name_S); + -- Target subprogram + + Asynch_P : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => Name_Asynchronous); + -- Is the procedure to which the 'Access applies asynchronous? + + All_Calls_Remote : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => Name_All_Calls_Remote); + -- True if an All_Calls_Remote pragma applies to the RCI unit + -- that contains the subprogram. + + -- Common local variables + + Proc_Decls : List_Id; + Proc_Statements : List_Id; + + Origin : constant Entity_Id := Make_Temporary (Loc, 'P'); + + -- Additional local variables for the local case + + Proxy_Addr : constant Entity_Id := Make_Temporary (Loc, 'P'); + + -- Additional local variables for the remote case + + Local_Stub : constant Entity_Id := Make_Temporary (Loc, 'L'); + Stub_Ptr : constant Entity_Id := Make_Temporary (Loc, 'S'); + + function Set_Field + (Field_Name : Name_Id; + Value : Node_Id) return Node_Id; + -- Construct an assignment that sets the named component in the + -- returned record + + --------------- + -- Set_Field -- + --------------- + + function Set_Field + (Field_Name : Name_Id; + Value : Node_Id) return Node_Id + is + begin + return + Make_Assignment_Statement (Loc, + Name => + Make_Selected_Component (Loc, + Prefix => Stub_Ptr, + Selector_Name => Field_Name), + Expression => Value); + end Set_Field; + + -- Start of processing for Add_RAS_Access_TSS + + begin + Proc_Decls := New_List ( + + -- Common declarations + + Make_Object_Declaration (Loc, + Defining_Identifier => Origin, + Constant_Present => True, + Object_Definition => + New_Occurrence_Of (RTE (RE_Partition_ID), Loc), + Expression => + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (RTE (RE_Get_Active_Partition_Id), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Package_Name, Loc)))), + + -- Declaration use only in the local case: proxy address + + Make_Object_Declaration (Loc, + Defining_Identifier => Proxy_Addr, + Object_Definition => + New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)), + + -- Declarations used only in the remote case: stub object and + -- stub pointer. + + Make_Object_Declaration (Loc, + Defining_Identifier => Local_Stub, + Aliased_Present => True, + Object_Definition => + New_Occurrence_Of (Stub_Elements.Stub_Type, Loc)), + + Make_Object_Declaration (Loc, + Defining_Identifier => + Stub_Ptr, + Object_Definition => + New_Occurrence_Of (Stub_Elements.Stub_Type_Access, Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Local_Stub, Loc), + Attribute_Name => Name_Unchecked_Access))); + + Set_Etype (Stub_Ptr, Stub_Elements.Stub_Type_Access); + + -- Build_Get_Unique_RP_Call needs above information + + -- Note: Here we assume that the Fat_Type is a record + -- containing just a pointer to a proxy or stub object. + + Proc_Statements := New_List ( + + -- Generate: + + -- Get_RAS_Info (Pkg, Subp, PA); + -- if Origin = Local_Partition_Id + -- and then not All_Calls_Remote + -- then + -- return Fat_Type!(PA); + -- end if; + + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (RTE (RE_Get_RAS_Info), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Package_Name, Loc), + New_Occurrence_Of (Subp_Id, Loc), + New_Occurrence_Of (Proxy_Addr, Loc))), + + Make_Implicit_If_Statement (N, + Condition => + Make_And_Then (Loc, + Left_Opnd => + Make_Op_Eq (Loc, + Left_Opnd => + New_Occurrence_Of (Origin, Loc), + Right_Opnd => + Make_Function_Call (Loc, + New_Occurrence_Of ( + RTE (RE_Get_Local_Partition_Id), Loc))), + + Right_Opnd => + Make_Op_Not (Loc, + New_Occurrence_Of (All_Calls_Remote, Loc))), + + Then_Statements => New_List ( + Make_Simple_Return_Statement (Loc, + Unchecked_Convert_To (Fat_Type, + OK_Convert_To (RTE (RE_Address), + New_Occurrence_Of (Proxy_Addr, Loc)))))), + + Set_Field (Name_Origin, + New_Occurrence_Of (Origin, Loc)), + + Set_Field (Name_Receiver, + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (RTE (RE_Get_RCI_Package_Receiver), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Package_Name, Loc)))), + + Set_Field (Name_Addr, New_Occurrence_Of (Proxy_Addr, Loc)), + + -- E.4.1(9) A remote call is asynchronous if it is a call to + -- a procedure or a call through a value of an access-to-procedure + -- type to which a pragma Asynchronous applies. + + -- Asynch_P is true when the procedure is asynchronous; + -- Asynch_T is true when the type is asynchronous. + + Set_Field (Name_Asynchronous, + Make_Or_Else (Loc, + New_Occurrence_Of (Asynch_P, Loc), + New_Occurrence_Of (Boolean_Literals ( + Is_Asynchronous (Ras_Type)), Loc)))); + + Append_List_To (Proc_Statements, + Build_Get_Unique_RP_Call + (Loc, Stub_Ptr, Stub_Elements.Stub_Type)); + + -- Return the newly created value + + Append_To (Proc_Statements, + Make_Simple_Return_Statement (Loc, + Expression => + Unchecked_Convert_To (Fat_Type, + New_Occurrence_Of (Stub_Ptr, Loc)))); + + Proc_Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => Proc, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Package_Name, + Parameter_Type => + New_Occurrence_Of (Standard_String, Loc)), + + Make_Parameter_Specification (Loc, + Defining_Identifier => Subp_Id, + Parameter_Type => + New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc)), + + Make_Parameter_Specification (Loc, + Defining_Identifier => Asynch_P, + Parameter_Type => + New_Occurrence_Of (Standard_Boolean, Loc)), + + Make_Parameter_Specification (Loc, + Defining_Identifier => All_Calls_Remote, + Parameter_Type => + New_Occurrence_Of (Standard_Boolean, Loc))), + + Result_Definition => + New_Occurrence_Of (Fat_Type, Loc)); + + -- Set the kind and return type of the function to prevent + -- ambiguities between Ras_Type and Fat_Type in subsequent analysis. + + Set_Ekind (Proc, E_Function); + Set_Etype (Proc, Fat_Type); + + Discard_Node ( + Make_Subprogram_Body (Loc, + Specification => Proc_Spec, + Declarations => Proc_Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Proc_Statements))); + + Set_TSS (Fat_Type, Proc); + end Add_RAS_Access_TSS; + + ----------------------- + -- Add_RAST_Features -- + ----------------------- + + procedure Add_RAST_Features + (Vis_Decl : Node_Id; + RAS_Type : Entity_Id) + is + pragma Unreferenced (RAS_Type); + begin + Add_RAS_Access_TSS (Vis_Decl); + end Add_RAST_Features; + + ----------------------------------------- + -- Add_Receiving_Stubs_To_Declarations -- + ----------------------------------------- + + procedure Add_Receiving_Stubs_To_Declarations + (Pkg_Spec : Node_Id; + Decls : List_Id; + Stmts : List_Id) + is + Loc : constant Source_Ptr := Sloc (Pkg_Spec); + + Request_Parameter : Node_Id; + + Pkg_RPC_Receiver : constant Entity_Id := + Make_Temporary (Loc, 'H'); + Pkg_RPC_Receiver_Statements : List_Id; + Pkg_RPC_Receiver_Cases : constant List_Id := New_List; + Pkg_RPC_Receiver_Body : Node_Id; + -- A Pkg_RPC_Receiver is built to decode the request + + Lookup_RAS : Node_Id; + Lookup_RAS_Info : constant Entity_Id := Make_Temporary (Loc, 'R'); + -- A remote subprogram is created to allow peers to look up RAS + -- information using subprogram ids. + + Subp_Id : Entity_Id; + Subp_Index : Entity_Id; + -- Subprogram_Id as read from the incoming stream + + Current_Subp_Number : Int := First_RCI_Subprogram_Id; + Current_Stubs : Node_Id; + + Subp_Info_Array : constant Entity_Id := Make_Temporary (Loc, 'I'); + Subp_Info_List : constant List_Id := New_List; + + Register_Pkg_Actuals : constant List_Id := New_List; + + All_Calls_Remote_E : Entity_Id; + Proxy_Object_Addr : Entity_Id; + + procedure Append_Stubs_To + (RPC_Receiver_Cases : List_Id; + Stubs : Node_Id; + Subprogram_Number : Int); + -- Add one case to the specified RPC receiver case list + -- associating Subprogram_Number with the subprogram declared + -- by Declaration, for which we have receiving stubs in Stubs. + + procedure Visit_Subprogram (Decl : Node_Id); + -- Generate receiving stub for one remote subprogram + + --------------------- + -- Append_Stubs_To -- + --------------------- + + procedure Append_Stubs_To + (RPC_Receiver_Cases : List_Id; + Stubs : Node_Id; + Subprogram_Number : Int) + is + begin + Append_To (RPC_Receiver_Cases, + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => + New_List (Make_Integer_Literal (Loc, Subprogram_Number)), + Statements => + New_List ( + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (Defining_Entity (Stubs), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Request_Parameter, Loc)))))); + end Append_Stubs_To; + + ---------------------- + -- Visit_Subprogram -- + ---------------------- + + procedure Visit_Subprogram (Decl : Node_Id) is + Loc : constant Source_Ptr := Sloc (Decl); + Spec : constant Node_Id := Specification (Decl); + Subp_Def : constant Entity_Id := Defining_Unit_Name (Spec); + + Subp_Val : String_Id; + pragma Warnings (Off, Subp_Val); + + begin + -- Disable expansion of stubs if serious errors have been + -- diagnosed, because otherwise some illegal remote subprogram + -- declarations could cause cascaded errors in stubs. + + if Serious_Errors_Detected /= 0 then + return; + end if; + + -- Build receiving stub + + Current_Stubs := + Build_Subprogram_Receiving_Stubs + (Vis_Decl => Decl, + Asynchronous => + Nkind (Spec) = N_Procedure_Specification + and then Is_Asynchronous (Subp_Def)); + + Append_To (Decls, Current_Stubs); + Analyze (Current_Stubs); + + -- Build RAS proxy + + Add_RAS_Proxy_And_Analyze (Decls, + Vis_Decl => Decl, + All_Calls_Remote_E => All_Calls_Remote_E, + Proxy_Object_Addr => Proxy_Object_Addr); + + -- Compute distribution identifier + + Assign_Subprogram_Identifier + (Subp_Def, Current_Subp_Number, Subp_Val); + + pragma Assert (Current_Subp_Number = Get_Subprogram_Id (Subp_Def)); + + -- Add subprogram descriptor (RCI_Subp_Info) to the subprograms + -- table for this receiver. This aggregate must be kept consistent + -- with the declaration of RCI_Subp_Info in + -- System.Partition_Interface. + + Append_To (Subp_Info_List, + Make_Component_Association (Loc, + Choices => New_List ( + Make_Integer_Literal (Loc, Current_Subp_Number)), + + Expression => + Make_Aggregate (Loc, + Component_Associations => New_List ( + + -- Addr => + + Make_Component_Association (Loc, + Choices => + New_List (Make_Identifier (Loc, Name_Addr)), + Expression => + New_Occurrence_Of (Proxy_Object_Addr, Loc)))))); + + Append_Stubs_To (Pkg_RPC_Receiver_Cases, + Stubs => Current_Stubs, + Subprogram_Number => Current_Subp_Number); + + Current_Subp_Number := Current_Subp_Number + 1; + end Visit_Subprogram; + + procedure Visit_Spec is new Build_Package_Stubs (Visit_Subprogram); + + -- Start of processing for Add_Receiving_Stubs_To_Declarations + + begin + -- Building receiving stubs consist in several operations: + + -- - a package RPC receiver must be built. This subprogram + -- will get a Subprogram_Id from the incoming stream + -- and will dispatch the call to the right subprogram; + + -- - a receiving stub for each subprogram visible in the package + -- spec. This stub will read all the parameters from the stream, + -- and put the result as well as the exception occurrence in the + -- output stream; + + -- - a dummy package with an empty spec and a body made of an + -- elaboration part, whose job is to register the receiving + -- part of this RCI package on the name server. This is done + -- by calling System.Partition_Interface.Register_Receiving_Stub. + + Build_RPC_Receiver_Body ( + RPC_Receiver => Pkg_RPC_Receiver, + Request => Request_Parameter, + Subp_Id => Subp_Id, + Subp_Index => Subp_Index, + Stmts => Pkg_RPC_Receiver_Statements, + Decl => Pkg_RPC_Receiver_Body); + pragma Assert (Subp_Id = Subp_Index); + + -- A null subp_id denotes a call through a RAS, in which case the + -- next Uint_64 element in the stream is the address of the local + -- proxy object, from which we can retrieve the actual subprogram id. + + Append_To (Pkg_RPC_Receiver_Statements, + Make_Implicit_If_Statement (Pkg_Spec, + Condition => + Make_Op_Eq (Loc, + New_Occurrence_Of (Subp_Id, Loc), + Make_Integer_Literal (Loc, 0)), + + Then_Statements => New_List ( + Make_Assignment_Statement (Loc, + Name => + New_Occurrence_Of (Subp_Id, Loc), + + Expression => + Make_Selected_Component (Loc, + Prefix => + Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access), + OK_Convert_To (RTE (RE_Address), + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (RTE (RE_Unsigned_64), Loc), + Attribute_Name => + Name_Input, + Expressions => New_List ( + Make_Selected_Component (Loc, + Prefix => Request_Parameter, + Selector_Name => Name_Params))))), + + Selector_Name => Make_Identifier (Loc, Name_Subp_Id)))))); + + -- Build a subprogram for RAS information lookups + + Lookup_RAS := + Make_Subprogram_Declaration (Loc, + Specification => + Make_Function_Specification (Loc, + Defining_Unit_Name => + Lookup_RAS_Info, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_Subp_Id), + In_Present => + True, + Parameter_Type => + New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc))), + Result_Definition => + New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))); + Append_To (Decls, Lookup_RAS); + Analyze (Lookup_RAS); + + Current_Stubs := Build_Subprogram_Receiving_Stubs + (Vis_Decl => Lookup_RAS, + Asynchronous => False); + Append_To (Decls, Current_Stubs); + Analyze (Current_Stubs); + + Append_Stubs_To (Pkg_RPC_Receiver_Cases, + Stubs => Current_Stubs, + Subprogram_Number => 1); + + -- For each subprogram, the receiving stub will be built and a + -- case statement will be made on the Subprogram_Id to dispatch + -- to the right subprogram. + + All_Calls_Remote_E := + Boolean_Literals + (Has_All_Calls_Remote (Defining_Entity (Pkg_Spec))); + + Overload_Counter_Table.Reset; + + Visit_Spec (Pkg_Spec); + + -- If we receive an invalid Subprogram_Id, it is best to do nothing + -- rather than raising an exception since we do not want someone + -- to crash a remote partition by sending invalid subprogram ids. + -- This is consistent with the other parts of the case statement + -- since even in presence of incorrect parameters in the stream, + -- every exception will be caught and (if the subprogram is not an + -- APC) put into the result stream and sent away. + + Append_To (Pkg_RPC_Receiver_Cases, + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => New_List (Make_Others_Choice (Loc)), + Statements => New_List (Make_Null_Statement (Loc)))); + + Append_To (Pkg_RPC_Receiver_Statements, + Make_Case_Statement (Loc, + Expression => New_Occurrence_Of (Subp_Id, Loc), + Alternatives => Pkg_RPC_Receiver_Cases)); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Subp_Info_Array, + Constant_Present => True, + Aliased_Present => True, + Object_Definition => + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Occurrence_Of (RTE (RE_RCI_Subp_Info_Array), Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + New_List ( + Make_Range (Loc, + Low_Bound => Make_Integer_Literal (Loc, + First_RCI_Subprogram_Id), + High_Bound => + Make_Integer_Literal (Loc, + Intval => + First_RCI_Subprogram_Id + + List_Length (Subp_Info_List) - 1))))))); + + -- For a degenerate RCI with no visible subprograms, Subp_Info_List + -- has zero length, and the declaration is for an empty array, in + -- which case no initialization aggregate must be generated. + + if Present (First (Subp_Info_List)) then + Set_Expression (Last (Decls), + Make_Aggregate (Loc, + Component_Associations => Subp_Info_List)); + + -- No initialization provided: remove CONSTANT so that the + -- declaration is not an incomplete deferred constant. + + else + Set_Constant_Present (Last (Decls), False); + end if; + + Analyze (Last (Decls)); + + declare + Subp_Info_Addr : Node_Id; + -- Return statement for Lookup_RAS_Info: address of the subprogram + -- information record for the requested subprogram id. + + begin + if Present (First (Subp_Info_List)) then + Subp_Info_Addr := + Make_Selected_Component (Loc, + Prefix => + Make_Indexed_Component (Loc, + Prefix => New_Occurrence_Of (Subp_Info_Array, Loc), + Expressions => New_List ( + Convert_To (Standard_Integer, + Make_Identifier (Loc, Name_Subp_Id)))), + Selector_Name => Make_Identifier (Loc, Name_Addr)); + + -- Case of no visible subprogram: just raise Constraint_Error, we + -- know for sure we got junk from a remote partition. + + else + Subp_Info_Addr := + Make_Raise_Constraint_Error (Loc, + Reason => CE_Range_Check_Failed); + Set_Etype (Subp_Info_Addr, RTE (RE_Unsigned_64)); + end if; + + Append_To (Decls, + Make_Subprogram_Body (Loc, + Specification => + Copy_Specification (Loc, Parent (Lookup_RAS_Info)), + Declarations => No_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Simple_Return_Statement (Loc, + Expression => + OK_Convert_To + (RTE (RE_Unsigned_64), Subp_Info_Addr)))))); + end; + + Analyze (Last (Decls)); + + Append_To (Decls, Pkg_RPC_Receiver_Body); + Analyze (Last (Decls)); + + Get_Library_Unit_Name_String (Pkg_Spec); + + -- Name + + Append_To (Register_Pkg_Actuals, + Make_String_Literal (Loc, + Strval => String_From_Name_Buffer)); + + -- Receiver + + Append_To (Register_Pkg_Actuals, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Pkg_RPC_Receiver, Loc), + Attribute_Name => Name_Unrestricted_Access)); + + -- Version + + Append_To (Register_Pkg_Actuals, + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc), + Attribute_Name => Name_Version)); + + -- Subp_Info + + Append_To (Register_Pkg_Actuals, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Subp_Info_Array, Loc), + Attribute_Name => Name_Address)); + + -- Subp_Info_Len + + Append_To (Register_Pkg_Actuals, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Subp_Info_Array, Loc), + Attribute_Name => Name_Length)); + + -- Generate the call + + Append_To (Stmts, + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Register_Receiving_Stub), Loc), + Parameter_Associations => Register_Pkg_Actuals)); + Analyze (Last (Stmts)); + end Add_Receiving_Stubs_To_Declarations; + + --------------------------------- + -- Build_General_Calling_Stubs -- + --------------------------------- + + procedure Build_General_Calling_Stubs + (Decls : List_Id; + Statements : List_Id; + Target_Partition : Entity_Id; + Target_RPC_Receiver : Node_Id; + Subprogram_Id : Node_Id; + Asynchronous : Node_Id := Empty; + Is_Known_Asynchronous : Boolean := False; + Is_Known_Non_Asynchronous : Boolean := False; + Is_Function : Boolean; + Spec : Node_Id; + Stub_Type : Entity_Id := Empty; + RACW_Type : Entity_Id := Empty; + Nod : Node_Id) + is + Loc : constant Source_Ptr := Sloc (Nod); + + Stream_Parameter : Node_Id; + -- Name of the stream used to transmit parameters to the remote + -- package. + + Result_Parameter : Node_Id; + -- Name of the result parameter (in non-APC cases) which get the + -- result of the remote subprogram. + + Exception_Return_Parameter : Node_Id; + -- Name of the parameter which will hold the exception sent by the + -- remote subprogram. + + Current_Parameter : Node_Id; + -- Current parameter being handled + + Ordered_Parameters_List : constant List_Id := + Build_Ordered_Parameters_List (Spec); + + Asynchronous_Statements : List_Id := No_List; + Non_Asynchronous_Statements : List_Id := No_List; + -- Statements specifics to the Asynchronous/Non-Asynchronous cases + + Extra_Formal_Statements : constant List_Id := New_List; + -- List of statements for extra formal parameters. It will appear + -- after the regular statements for writing out parameters. + + pragma Unreferenced (RACW_Type); + -- Used only for the PolyORB case + + begin + -- The general form of a calling stub for a given subprogram is: + + -- procedure X (...) is P : constant Partition_ID := + -- RCI_Cache.Get_Active_Partition_ID; Stream, Result : aliased + -- System.RPC.Params_Stream_Type (0); begin + -- Put_Package_RPC_Receiver_In_Stream; (the package RPC receiver + -- comes from RCI_Cache.Get_RCI_Package_Receiver) + -- Put_Subprogram_Id_In_Stream; Put_Parameters_In_Stream; Do_RPC + -- (Stream, Result); Read_Exception_Occurrence_From_Result; + -- Raise_It; + -- Read_Out_Parameters_And_Function_Return_From_Stream; end X; + + -- There are some variations: Do_APC is called for an asynchronous + -- procedure and the part after the call is completely ommitted as + -- well as the declaration of Result. For a function call, 'Input is + -- always used to read the result even if it is constrained. + + Stream_Parameter := Make_Temporary (Loc, 'S'); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Stream_Parameter, + Aliased_Present => True, + Object_Definition => + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => + New_List (Make_Integer_Literal (Loc, 0)))))); + + if not Is_Known_Asynchronous then + Result_Parameter := Make_Temporary (Loc, 'R'); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Result_Parameter, + Aliased_Present => True, + Object_Definition => + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => + New_List (Make_Integer_Literal (Loc, 0)))))); + + Exception_Return_Parameter := Make_Temporary (Loc, 'E'); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Exception_Return_Parameter, + Object_Definition => + New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc))); + + else + Result_Parameter := Empty; + Exception_Return_Parameter := Empty; + end if; + + -- Put first the RPC receiver corresponding to the remote package + + Append_To (Statements, + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (RTE (RE_Unsigned_64), Loc), + Attribute_Name => Name_Write, + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Stream_Parameter, Loc), + Attribute_Name => Name_Access), + Target_RPC_Receiver))); + + -- Then put the Subprogram_Id of the subprogram we want to call in + -- the stream. + + Append_To (Statements, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc), + Attribute_Name => Name_Write, + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Stream_Parameter, Loc), + Attribute_Name => Name_Access), + Subprogram_Id))); + + Current_Parameter := First (Ordered_Parameters_List); + while Present (Current_Parameter) loop + declare + Typ : constant Node_Id := + Parameter_Type (Current_Parameter); + Etyp : Entity_Id; + Constrained : Boolean; + Value : Node_Id; + Extra_Parameter : Entity_Id; + + begin + if Is_RACW_Controlling_Formal + (Current_Parameter, Stub_Type) + then + -- In the case of a controlling formal argument, we marshall + -- its addr field rather than the local stub. + + Append_To (Statements, + Pack_Node_Into_Stream (Loc, + Stream => Stream_Parameter, + Object => + Make_Selected_Component (Loc, + Prefix => + Defining_Identifier (Current_Parameter), + Selector_Name => Name_Addr), + Etyp => RTE (RE_Unsigned_64))); + + else + Value := + New_Occurrence_Of + (Defining_Identifier (Current_Parameter), Loc); + + -- Access type parameters are transmitted as in out + -- parameters. However, a dereference is needed so that + -- we marshall the designated object. + + if Nkind (Typ) = N_Access_Definition then + Value := Make_Explicit_Dereference (Loc, Value); + Etyp := Etype (Subtype_Mark (Typ)); + else + Etyp := Etype (Typ); + end if; + + Constrained := not Transmit_As_Unconstrained (Etyp); + + -- Any parameter but unconstrained out parameters are + -- transmitted to the peer. + + if In_Present (Current_Parameter) + or else not Out_Present (Current_Parameter) + or else not Constrained + then + Append_To (Statements, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Etyp, Loc), + Attribute_Name => + Output_From_Constrained (Constrained), + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Stream_Parameter, Loc), + Attribute_Name => Name_Access), + Value))); + end if; + end if; + + -- If the current parameter has a dynamic constrained status, + -- then this status is transmitted as well. + -- This should be done for accessibility as well ??? + + if Nkind (Typ) /= N_Access_Definition + and then Need_Extra_Constrained (Current_Parameter) + then + -- In this block, we do not use the extra formal that has + -- been created because it does not exist at the time of + -- expansion when building calling stubs for remote access + -- to subprogram types. We create an extra variable of this + -- type and push it in the stream after the regular + -- parameters. + + Extra_Parameter := Make_Temporary (Loc, 'P'); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Extra_Parameter, + Constant_Present => True, + Object_Definition => + New_Occurrence_Of (Standard_Boolean, Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of ( + Defining_Identifier (Current_Parameter), Loc), + Attribute_Name => Name_Constrained))); + + Append_To (Extra_Formal_Statements, + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Standard_Boolean, Loc), + Attribute_Name => Name_Write, + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of + (Stream_Parameter, Loc), Attribute_Name => + Name_Access), + New_Occurrence_Of (Extra_Parameter, Loc)))); + end if; + + Next (Current_Parameter); + end; + end loop; + + -- Append the formal statements list to the statements + + Append_List_To (Statements, Extra_Formal_Statements); + + if not Is_Known_Non_Asynchronous then + + -- Build the call to System.RPC.Do_APC + + Asynchronous_Statements := New_List ( + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Do_Apc), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Target_Partition, Loc), + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Stream_Parameter, Loc), + Attribute_Name => Name_Access)))); + else + Asynchronous_Statements := No_List; + end if; + + if not Is_Known_Asynchronous then + + -- Build the call to System.RPC.Do_RPC + + Non_Asynchronous_Statements := New_List ( + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Do_Rpc), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Target_Partition, Loc), + + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Stream_Parameter, Loc), + Attribute_Name => Name_Access), + + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Result_Parameter, Loc), + Attribute_Name => Name_Access)))); + + -- Read the exception occurrence from the result stream and + -- reraise it. It does no harm if this is a Null_Occurrence since + -- this does nothing. + + Append_To (Non_Asynchronous_Statements, + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc), + + Attribute_Name => Name_Read, + + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Result_Parameter, Loc), + Attribute_Name => Name_Access), + New_Occurrence_Of (Exception_Return_Parameter, Loc)))); + + Append_To (Non_Asynchronous_Statements, + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Reraise_Occurrence), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Exception_Return_Parameter, Loc)))); + + if Is_Function then + + -- If this is a function call, then read the value and return + -- it. The return value is written/read using 'Output/'Input. + + Append_To (Non_Asynchronous_Statements, + Make_Tag_Check (Loc, + Make_Simple_Return_Statement (Loc, + Expression => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of ( + Etype (Result_Definition (Spec)), Loc), + + Attribute_Name => Name_Input, + + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Result_Parameter, Loc), + Attribute_Name => Name_Access)))))); + + else + -- Loop around parameters and assign out (or in out) + -- parameters. In the case of RACW, controlling arguments + -- cannot possibly have changed since they are remote, so + -- we do not read them from the stream. + + Current_Parameter := First (Ordered_Parameters_List); + while Present (Current_Parameter) loop + declare + Typ : constant Node_Id := + Parameter_Type (Current_Parameter); + Etyp : Entity_Id; + Value : Node_Id; + + begin + Value := + New_Occurrence_Of + (Defining_Identifier (Current_Parameter), Loc); + + if Nkind (Typ) = N_Access_Definition then + Value := Make_Explicit_Dereference (Loc, Value); + Etyp := Etype (Subtype_Mark (Typ)); + else + Etyp := Etype (Typ); + end if; + + if (Out_Present (Current_Parameter) + or else Nkind (Typ) = N_Access_Definition) + and then Etyp /= Stub_Type + then + Append_To (Non_Asynchronous_Statements, + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Etyp, Loc), + + Attribute_Name => Name_Read, + + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Result_Parameter, Loc), + Attribute_Name => Name_Access), + Value))); + end if; + end; + + Next (Current_Parameter); + end loop; + end if; + end if; + + if Is_Known_Asynchronous then + Append_List_To (Statements, Asynchronous_Statements); + + elsif Is_Known_Non_Asynchronous then + Append_List_To (Statements, Non_Asynchronous_Statements); + + else + pragma Assert (Present (Asynchronous)); + Prepend_To (Asynchronous_Statements, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Standard_Boolean, Loc), + Attribute_Name => Name_Write, + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Stream_Parameter, Loc), + Attribute_Name => Name_Access), + New_Occurrence_Of (Standard_True, Loc)))); + + Prepend_To (Non_Asynchronous_Statements, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Standard_Boolean, Loc), + Attribute_Name => Name_Write, + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Stream_Parameter, Loc), + Attribute_Name => Name_Access), + New_Occurrence_Of (Standard_False, Loc)))); + + Append_To (Statements, + Make_Implicit_If_Statement (Nod, + Condition => Asynchronous, + Then_Statements => Asynchronous_Statements, + Else_Statements => Non_Asynchronous_Statements)); + end if; + end Build_General_Calling_Stubs; + + ----------------------------- + -- Build_RPC_Receiver_Body -- + ----------------------------- + + procedure Build_RPC_Receiver_Body + (RPC_Receiver : Entity_Id; + Request : out Entity_Id; + Subp_Id : out Entity_Id; + Subp_Index : out Entity_Id; + Stmts : out List_Id; + Decl : out Node_Id) + is + Loc : constant Source_Ptr := Sloc (RPC_Receiver); + + RPC_Receiver_Spec : Node_Id; + RPC_Receiver_Decls : List_Id; + + begin + Request := Make_Defining_Identifier (Loc, Name_R); + + RPC_Receiver_Spec := + Build_RPC_Receiver_Specification + (RPC_Receiver => RPC_Receiver, + Request_Parameter => Request); + + Subp_Id := Make_Temporary (Loc, 'P'); + Subp_Index := Subp_Id; + + -- Subp_Id may not be a constant, because in the case of the RPC + -- receiver for an RCI package, when a call is received from a RAS + -- dereference, it will be assigned during subsequent processing. + + RPC_Receiver_Decls := New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => Subp_Id, + Object_Definition => + New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc), + Attribute_Name => Name_Input, + Expressions => New_List ( + Make_Selected_Component (Loc, + Prefix => Request, + Selector_Name => Name_Params))))); + + Stmts := New_List; + + Decl := + Make_Subprogram_Body (Loc, + Specification => RPC_Receiver_Spec, + Declarations => RPC_Receiver_Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stmts)); + end Build_RPC_Receiver_Body; + + ----------------------- + -- Build_Stub_Target -- + ----------------------- + + function Build_Stub_Target + (Loc : Source_Ptr; + Decls : List_Id; + RCI_Locator : Entity_Id; + Controlling_Parameter : Entity_Id) return RPC_Target + is + Target_Info : RPC_Target (PCS_Kind => Name_GARLIC_DSA); + + begin + Target_Info.Partition := Make_Temporary (Loc, 'P'); + + if Present (Controlling_Parameter) then + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Target_Info.Partition, + Constant_Present => True, + Object_Definition => + New_Occurrence_Of (RTE (RE_Partition_ID), Loc), + + Expression => + Make_Selected_Component (Loc, + Prefix => Controlling_Parameter, + Selector_Name => Name_Origin))); + + Target_Info.RPC_Receiver := + Make_Selected_Component (Loc, + Prefix => Controlling_Parameter, + Selector_Name => Name_Receiver); + + else + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Target_Info.Partition, + Constant_Present => True, + Object_Definition => + New_Occurrence_Of (RTE (RE_Partition_ID), Loc), + + Expression => + Make_Function_Call (Loc, + Name => Make_Selected_Component (Loc, + Prefix => + Make_Identifier (Loc, Chars (RCI_Locator)), + Selector_Name => + Make_Identifier (Loc, + Name_Get_Active_Partition_ID))))); + + Target_Info.RPC_Receiver := + Make_Selected_Component (Loc, + Prefix => + Make_Identifier (Loc, Chars (RCI_Locator)), + Selector_Name => + Make_Identifier (Loc, Name_Get_RCI_Package_Receiver)); + end if; + return Target_Info; + end Build_Stub_Target; + + -------------------------------------- + -- Build_Subprogram_Receiving_Stubs -- + -------------------------------------- + + function Build_Subprogram_Receiving_Stubs + (Vis_Decl : Node_Id; + Asynchronous : Boolean; + Dynamically_Asynchronous : Boolean := False; + Stub_Type : Entity_Id := Empty; + RACW_Type : Entity_Id := Empty; + Parent_Primitive : Entity_Id := Empty) return Node_Id + is + Loc : constant Source_Ptr := Sloc (Vis_Decl); + + Request_Parameter : constant Entity_Id := Make_Temporary (Loc, 'R'); + -- Formal parameter for receiving stubs: a descriptor for an incoming + -- request. + + Decls : constant List_Id := New_List; + -- All the parameters will get declared before calling the real + -- subprograms. Also the out parameters will be declared. + + Statements : constant List_Id := New_List; + + Extra_Formal_Statements : constant List_Id := New_List; + -- Statements concerning extra formal parameters + + After_Statements : constant List_Id := New_List; + -- Statements to be executed after the subprogram call + + Inner_Decls : List_Id := No_List; + -- In case of a function, the inner declarations are needed since + -- the result may be unconstrained. + + Excep_Handlers : List_Id := No_List; + Excep_Choice : Entity_Id; + Excep_Code : List_Id; + + Parameter_List : constant List_Id := New_List; + -- List of parameters to be passed to the subprogram + + Current_Parameter : Node_Id; + + Ordered_Parameters_List : constant List_Id := + Build_Ordered_Parameters_List + (Specification (Vis_Decl)); + + Subp_Spec : Node_Id; + -- Subprogram specification + + Called_Subprogram : Node_Id; + -- The subprogram to call + + Null_Raise_Statement : Node_Id; + + Dynamic_Async : Entity_Id; + + begin + if Present (RACW_Type) then + Called_Subprogram := New_Occurrence_Of (Parent_Primitive, Loc); + else + Called_Subprogram := + New_Occurrence_Of + (Defining_Unit_Name (Specification (Vis_Decl)), Loc); + end if; + + if Dynamically_Asynchronous then + Dynamic_Async := Make_Temporary (Loc, 'S'); + else + Dynamic_Async := Empty; + end if; + + if not Asynchronous or Dynamically_Asynchronous then + + -- The first statement after the subprogram call is a statement to + -- write a Null_Occurrence into the result stream. + + Null_Raise_Statement := + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc), + Attribute_Name => Name_Write, + Expressions => New_List ( + Make_Selected_Component (Loc, + Prefix => Request_Parameter, + Selector_Name => Name_Result), + New_Occurrence_Of (RTE (RE_Null_Occurrence), Loc))); + + if Dynamically_Asynchronous then + Null_Raise_Statement := + Make_Implicit_If_Statement (Vis_Decl, + Condition => + Make_Op_Not (Loc, New_Occurrence_Of (Dynamic_Async, Loc)), + Then_Statements => New_List (Null_Raise_Statement)); + end if; + + Append_To (After_Statements, Null_Raise_Statement); + end if; + + -- Loop through every parameter and get its value from the stream. If + -- the parameter is unconstrained, then the parameter is read using + -- 'Input at the point of declaration. + + Current_Parameter := First (Ordered_Parameters_List); + while Present (Current_Parameter) loop + declare + Etyp : Entity_Id; + Constrained : Boolean; + + Need_Extra_Constrained : Boolean; + -- True when an Extra_Constrained actual is required + + Object : constant Entity_Id := Make_Temporary (Loc, 'P'); + + Expr : Node_Id := Empty; + + Is_Controlling_Formal : constant Boolean := + Is_RACW_Controlling_Formal + (Current_Parameter, Stub_Type); + + begin + if Is_Controlling_Formal then + + -- We have a controlling formal parameter. Read its address + -- rather than a real object. The address is in Unsigned_64 + -- form. + + Etyp := RTE (RE_Unsigned_64); + else + Etyp := Etype (Parameter_Type (Current_Parameter)); + end if; + + Constrained := not Transmit_As_Unconstrained (Etyp); + + if In_Present (Current_Parameter) + or else not Out_Present (Current_Parameter) + or else not Constrained + or else Is_Controlling_Formal + then + -- If an input parameter is constrained, then the read of + -- the parameter is deferred until the beginning of the + -- subprogram body. If it is unconstrained, then an + -- expression is built for the object declaration and the + -- variable is set using 'Input instead of 'Read. Note that + -- this deferral does not change the order in which the + -- actuals are read because Build_Ordered_Parameter_List + -- puts them unconstrained first. + + if Constrained then + Append_To (Statements, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Etyp, Loc), + Attribute_Name => Name_Read, + Expressions => New_List ( + Make_Selected_Component (Loc, + Prefix => Request_Parameter, + Selector_Name => Name_Params), + New_Occurrence_Of (Object, Loc)))); + + else + + -- Build and append Input_With_Tag_Check function + + Append_To (Decls, + Input_With_Tag_Check (Loc, + Var_Type => Etyp, + Stream => + Make_Selected_Component (Loc, + Prefix => Request_Parameter, + Selector_Name => Name_Params))); + + -- Prepare function call expression + + Expr := + Make_Function_Call (Loc, + Name => + New_Occurrence_Of + (Defining_Unit_Name + (Specification (Last (Decls))), Loc)); + end if; + end if; + + Need_Extra_Constrained := + Nkind (Parameter_Type (Current_Parameter)) /= + N_Access_Definition + and then + Ekind (Defining_Identifier (Current_Parameter)) /= E_Void + and then + Present (Extra_Constrained + (Defining_Identifier (Current_Parameter))); + + -- We may not associate an extra constrained actual to a + -- constant object, so if one is needed, declare the actual + -- as a variable even if it won't be modified. + + Build_Actual_Object_Declaration + (Object => Object, + Etyp => Etyp, + Variable => Need_Extra_Constrained + or else Out_Present (Current_Parameter), + Expr => Expr, + Decls => Decls); + + -- An out parameter may be written back using a 'Write + -- attribute instead of a 'Output because it has been + -- constrained by the parameter given to the caller. Note that + -- out controlling arguments in the case of a RACW are not put + -- back in the stream because the pointer on them has not + -- changed. + + if Out_Present (Current_Parameter) + and then + Etype (Parameter_Type (Current_Parameter)) /= Stub_Type + then + Append_To (After_Statements, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Etyp, Loc), + Attribute_Name => Name_Write, + Expressions => New_List ( + Make_Selected_Component (Loc, + Prefix => Request_Parameter, + Selector_Name => Name_Result), + New_Occurrence_Of (Object, Loc)))); + end if; + + -- For RACW controlling formals, the Etyp of Object is always + -- an RACW, even if the parameter is not of an anonymous access + -- type. In such case, we need to dereference it at call time. + + if Is_Controlling_Formal then + if Nkind (Parameter_Type (Current_Parameter)) /= + N_Access_Definition + then + Append_To (Parameter_List, + Make_Parameter_Association (Loc, + Selector_Name => + New_Occurrence_Of ( + Defining_Identifier (Current_Parameter), Loc), + Explicit_Actual_Parameter => + Make_Explicit_Dereference (Loc, + Unchecked_Convert_To (RACW_Type, + OK_Convert_To (RTE (RE_Address), + New_Occurrence_Of (Object, Loc)))))); + + else + Append_To (Parameter_List, + Make_Parameter_Association (Loc, + Selector_Name => + New_Occurrence_Of ( + Defining_Identifier (Current_Parameter), Loc), + Explicit_Actual_Parameter => + Unchecked_Convert_To (RACW_Type, + OK_Convert_To (RTE (RE_Address), + New_Occurrence_Of (Object, Loc))))); + end if; + + else + Append_To (Parameter_List, + Make_Parameter_Association (Loc, + Selector_Name => + New_Occurrence_Of ( + Defining_Identifier (Current_Parameter), Loc), + Explicit_Actual_Parameter => + New_Occurrence_Of (Object, Loc))); + end if; + + -- If the current parameter needs an extra formal, then read it + -- from the stream and set the corresponding semantic field in + -- the variable. If the kind of the parameter identifier is + -- E_Void, then this is a compiler generated parameter that + -- doesn't need an extra constrained status. + + -- The case of Extra_Accessibility should also be handled ??? + + if Need_Extra_Constrained then + declare + Extra_Parameter : constant Entity_Id := + Extra_Constrained + (Defining_Identifier + (Current_Parameter)); + + Formal_Entity : constant Entity_Id := + Make_Defining_Identifier + (Loc, Chars (Extra_Parameter)); + + Formal_Type : constant Entity_Id := + Etype (Extra_Parameter); + + begin + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Formal_Entity, + Object_Definition => + New_Occurrence_Of (Formal_Type, Loc))); + + Append_To (Extra_Formal_Statements, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of ( + Formal_Type, Loc), + Attribute_Name => Name_Read, + Expressions => New_List ( + Make_Selected_Component (Loc, + Prefix => Request_Parameter, + Selector_Name => Name_Params), + New_Occurrence_Of (Formal_Entity, Loc)))); + + -- Note: the call to Set_Extra_Constrained below relies + -- on the fact that Object's Ekind has been set by + -- Build_Actual_Object_Declaration. + + Set_Extra_Constrained (Object, Formal_Entity); + end; + end if; + end; + + Next (Current_Parameter); + end loop; + + -- Append the formal statements list at the end of regular statements + + Append_List_To (Statements, Extra_Formal_Statements); + + if Nkind (Specification (Vis_Decl)) = N_Function_Specification then + + -- The remote subprogram is a function. We build an inner block to + -- be able to hold a potentially unconstrained result in a + -- variable. + + declare + Etyp : constant Entity_Id := + Etype (Result_Definition (Specification (Vis_Decl))); + Result : constant Node_Id := Make_Temporary (Loc, 'R'); + + begin + Inner_Decls := New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => Result, + Constant_Present => True, + Object_Definition => New_Occurrence_Of (Etyp, Loc), + Expression => + Make_Function_Call (Loc, + Name => Called_Subprogram, + Parameter_Associations => Parameter_List))); + + if Is_Class_Wide_Type (Etyp) then + + -- For a remote call to a function with a class-wide type, + -- check that the returned value satisfies the requirements + -- of E.4(18). + + Append_To (Inner_Decls, + Make_Transportable_Check (Loc, + New_Occurrence_Of (Result, Loc))); + + end if; + + Append_To (After_Statements, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Etyp, Loc), + Attribute_Name => Name_Output, + Expressions => New_List ( + Make_Selected_Component (Loc, + Prefix => Request_Parameter, + Selector_Name => Name_Result), + New_Occurrence_Of (Result, Loc)))); + end; + + Append_To (Statements, + Make_Block_Statement (Loc, + Declarations => Inner_Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => After_Statements))); + + else + -- The remote subprogram is a procedure. We do not need any inner + -- block in this case. + + if Dynamically_Asynchronous then + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Dynamic_Async, + Object_Definition => + New_Occurrence_Of (Standard_Boolean, Loc))); + + Append_To (Statements, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Standard_Boolean, Loc), + Attribute_Name => Name_Read, + Expressions => New_List ( + Make_Selected_Component (Loc, + Prefix => Request_Parameter, + Selector_Name => Name_Params), + New_Occurrence_Of (Dynamic_Async, Loc)))); + end if; + + Append_To (Statements, + Make_Procedure_Call_Statement (Loc, + Name => Called_Subprogram, + Parameter_Associations => Parameter_List)); + + Append_List_To (Statements, After_Statements); + end if; + + if Asynchronous and then not Dynamically_Asynchronous then + + -- For an asynchronous procedure, add a null exception handler + + Excep_Handlers := New_List ( + Make_Implicit_Exception_Handler (Loc, + Exception_Choices => New_List (Make_Others_Choice (Loc)), + Statements => New_List (Make_Null_Statement (Loc)))); + + else + -- In the other cases, if an exception is raised, then the + -- exception occurrence is copied into the output stream and + -- no other output parameter is written. + + Excep_Choice := Make_Temporary (Loc, 'E'); + + Excep_Code := New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc), + Attribute_Name => Name_Write, + Expressions => New_List ( + Make_Selected_Component (Loc, + Prefix => Request_Parameter, + Selector_Name => Name_Result), + New_Occurrence_Of (Excep_Choice, Loc)))); + + if Dynamically_Asynchronous then + Excep_Code := New_List ( + Make_Implicit_If_Statement (Vis_Decl, + Condition => Make_Op_Not (Loc, + New_Occurrence_Of (Dynamic_Async, Loc)), + Then_Statements => Excep_Code)); + end if; + + Excep_Handlers := New_List ( + Make_Implicit_Exception_Handler (Loc, + Choice_Parameter => Excep_Choice, + Exception_Choices => New_List (Make_Others_Choice (Loc)), + Statements => Excep_Code)); + + end if; + + Subp_Spec := + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Make_Temporary (Loc, 'F'), + + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Request_Parameter, + Parameter_Type => + New_Occurrence_Of (RTE (RE_Request_Access), Loc)))); + + return + Make_Subprogram_Body (Loc, + Specification => Subp_Spec, + Declarations => Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Statements, + Exception_Handlers => Excep_Handlers)); + end Build_Subprogram_Receiving_Stubs; + + ------------ + -- Result -- + ------------ + + function Result return Node_Id is + begin + return Make_Identifier (Loc, Name_V); + end Result; + + ----------------------- + -- RPC_Receiver_Decl -- + ----------------------- + + function RPC_Receiver_Decl (RACW_Type : Entity_Id) return Node_Id is + Loc : constant Source_Ptr := Sloc (RACW_Type); + Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type); + + begin + -- No RPC receiver for remote access-to-subprogram + + if Is_RAS then + return Empty; + end if; + + return + Make_Subprogram_Declaration (Loc, + Build_RPC_Receiver_Specification + (RPC_Receiver => Make_Temporary (Loc, 'R'), + Request_Parameter => Make_Defining_Identifier (Loc, Name_R))); + end RPC_Receiver_Decl; + + ---------------------- + -- Stream_Parameter -- + ---------------------- + + function Stream_Parameter return Node_Id is + begin + return Make_Identifier (Loc, Name_S); + end Stream_Parameter; + + end GARLIC_Support; + + ------------------------------- + -- Get_And_Reset_RACW_Bodies -- + ------------------------------- + + function Get_And_Reset_RACW_Bodies (RACW_Type : Entity_Id) return List_Id is + Desig : constant Entity_Id := + Etype (Designated_Type (RACW_Type)); + + Stub_Elements : Stub_Structure := Stubs_Table.Get (Desig); + + Body_Decls : List_Id; + -- Returned list of declarations + + begin + if Stub_Elements = Empty_Stub_Structure then + + -- Stub elements may be missing as a consequence of a previously + -- detected error. + + return No_List; + end if; + + Body_Decls := Stub_Elements.Body_Decls; + Stub_Elements.Body_Decls := No_List; + Stubs_Table.Set (Desig, Stub_Elements); + return Body_Decls; + end Get_And_Reset_RACW_Bodies; + + ----------------------- + -- Get_Stub_Elements -- + ----------------------- + + function Get_Stub_Elements (RACW_Type : Entity_Id) return Stub_Structure is + Desig : constant Entity_Id := + Etype (Designated_Type (RACW_Type)); + Stub_Elements : constant Stub_Structure := Stubs_Table.Get (Desig); + begin + pragma Assert (Stub_Elements /= Empty_Stub_Structure); + return Stub_Elements; + end Get_Stub_Elements; + + ----------------------- + -- Get_Subprogram_Id -- + ----------------------- + + function Get_Subprogram_Id (Def : Entity_Id) return String_Id is + Result : constant String_Id := Get_Subprogram_Ids (Def).Str_Identifier; + begin + pragma Assert (Result /= No_String); + return Result; + end Get_Subprogram_Id; + + ----------------------- + -- Get_Subprogram_Id -- + ----------------------- + + function Get_Subprogram_Id (Def : Entity_Id) return Int is + begin + return Get_Subprogram_Ids (Def).Int_Identifier; + end Get_Subprogram_Id; + + ------------------------ + -- Get_Subprogram_Ids -- + ------------------------ + + function Get_Subprogram_Ids + (Def : Entity_Id) return Subprogram_Identifiers + is + begin + return Subprogram_Identifier_Table.Get (Def); + end Get_Subprogram_Ids; + + ---------- + -- Hash -- + ---------- + + function Hash (F : Entity_Id) return Hash_Index is + begin + return Hash_Index (Natural (F) mod Positive (Hash_Index'Last + 1)); + end Hash; + + function Hash (F : Name_Id) return Hash_Index is + begin + return Hash_Index (Natural (F) mod Positive (Hash_Index'Last + 1)); + end Hash; + + -------------------------- + -- Input_With_Tag_Check -- + -------------------------- + + function Input_With_Tag_Check + (Loc : Source_Ptr; + Var_Type : Entity_Id; + Stream : Node_Id) return Node_Id + is + begin + return + Make_Subprogram_Body (Loc, + Specification => + Make_Function_Specification (Loc, + Defining_Unit_Name => Make_Temporary (Loc, 'S'), + Result_Definition => New_Occurrence_Of (Var_Type, Loc)), + Declarations => No_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, New_List ( + Make_Tag_Check (Loc, + Make_Simple_Return_Statement (Loc, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Var_Type, Loc), + Attribute_Name => Name_Input, + Expressions => + New_List (Stream))))))); + end Input_With_Tag_Check; + + -------------------------------- + -- Is_RACW_Controlling_Formal -- + -------------------------------- + + function Is_RACW_Controlling_Formal + (Parameter : Node_Id; + Stub_Type : Entity_Id) return Boolean + is + Typ : Entity_Id; + + begin + -- If the kind of the parameter is E_Void, then it is not a controlling + -- formal (this can happen in the context of RAS). + + if Ekind (Defining_Identifier (Parameter)) = E_Void then + return False; + end if; + + -- If the parameter is not a controlling formal, then it cannot be + -- possibly a RACW_Controlling_Formal. + + if not Is_Controlling_Formal (Defining_Identifier (Parameter)) then + return False; + end if; + + Typ := Parameter_Type (Parameter); + return (Nkind (Typ) = N_Access_Definition + and then Etype (Subtype_Mark (Typ)) = Stub_Type) + or else Etype (Typ) = Stub_Type; + end Is_RACW_Controlling_Formal; + + ------------------------------ + -- Make_Transportable_Check -- + ------------------------------ + + function Make_Transportable_Check + (Loc : Source_Ptr; + Expr : Node_Id) return Node_Id is + begin + return + Make_Raise_Program_Error (Loc, + Condition => + Make_Op_Not (Loc, + Build_Get_Transportable (Loc, + Make_Selected_Component (Loc, + Prefix => Expr, + Selector_Name => Make_Identifier (Loc, Name_uTag)))), + Reason => PE_Non_Transportable_Actual); + end Make_Transportable_Check; + + ----------------------------- + -- Make_Selected_Component -- + ----------------------------- + + function Make_Selected_Component + (Loc : Source_Ptr; + Prefix : Entity_Id; + Selector_Name : Name_Id) return Node_Id + is + begin + return Make_Selected_Component (Loc, + Prefix => New_Occurrence_Of (Prefix, Loc), + Selector_Name => Make_Identifier (Loc, Selector_Name)); + end Make_Selected_Component; + + -------------------- + -- Make_Tag_Check -- + -------------------- + + function Make_Tag_Check (Loc : Source_Ptr; N : Node_Id) return Node_Id is + Occ : constant Entity_Id := Make_Temporary (Loc, 'E'); + + begin + return Make_Block_Statement (Loc, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (N), + + Exception_Handlers => New_List ( + Make_Implicit_Exception_Handler (Loc, + Choice_Parameter => Occ, + + Exception_Choices => + New_List (New_Occurrence_Of (RTE (RE_Tag_Error), Loc)), + + Statements => + New_List (Make_Procedure_Call_Statement (Loc, + New_Occurrence_Of + (RTE (RE_Raise_Program_Error_Unknown_Tag), Loc), + New_List (New_Occurrence_Of (Occ, Loc)))))))); + end Make_Tag_Check; + + ---------------------------- + -- Need_Extra_Constrained -- + ---------------------------- + + function Need_Extra_Constrained (Parameter : Node_Id) return Boolean is + Etyp : constant Entity_Id := Etype (Parameter_Type (Parameter)); + begin + return Out_Present (Parameter) + and then Has_Discriminants (Etyp) + and then not Is_Constrained (Etyp) + and then not Is_Indefinite_Subtype (Etyp); + end Need_Extra_Constrained; + + ------------------------------------ + -- Pack_Entity_Into_Stream_Access -- + ------------------------------------ + + function Pack_Entity_Into_Stream_Access + (Loc : Source_Ptr; + Stream : Node_Id; + Object : Entity_Id; + Etyp : Entity_Id := Empty) return Node_Id + is + Typ : Entity_Id; + + begin + if Present (Etyp) then + Typ := Etyp; + else + Typ := Etype (Object); + end if; + + return + Pack_Node_Into_Stream_Access (Loc, + Stream => Stream, + Object => New_Occurrence_Of (Object, Loc), + Etyp => Typ); + end Pack_Entity_Into_Stream_Access; + + --------------------------- + -- Pack_Node_Into_Stream -- + --------------------------- + + function Pack_Node_Into_Stream + (Loc : Source_Ptr; + Stream : Entity_Id; + Object : Node_Id; + Etyp : Entity_Id) return Node_Id + is + Write_Attribute : Name_Id := Name_Write; + + begin + if not Is_Constrained (Etyp) then + Write_Attribute := Name_Output; + end if; + + return + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Etyp, Loc), + Attribute_Name => Write_Attribute, + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Stream, Loc), + Attribute_Name => Name_Access), + Object)); + end Pack_Node_Into_Stream; + + ---------------------------------- + -- Pack_Node_Into_Stream_Access -- + ---------------------------------- + + function Pack_Node_Into_Stream_Access + (Loc : Source_Ptr; + Stream : Node_Id; + Object : Node_Id; + Etyp : Entity_Id) return Node_Id + is + Write_Attribute : Name_Id := Name_Write; + + begin + if not Is_Constrained (Etyp) then + Write_Attribute := Name_Output; + end if; + + return + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Etyp, Loc), + Attribute_Name => Write_Attribute, + Expressions => New_List ( + Stream, + Object)); + end Pack_Node_Into_Stream_Access; + + --------------------- + -- PolyORB_Support -- + --------------------- + + package body PolyORB_Support is + + -- Local subprograms + + procedure Add_RACW_Read_Attribute + (RACW_Type : Entity_Id; + Stub_Type : Entity_Id; + Stub_Type_Access : Entity_Id; + Body_Decls : List_Id); + -- Add Read attribute for the RACW type. The declaration and attribute + -- definition clauses are inserted right after the declaration of + -- RACW_Type. If Body_Decls is not No_List, the subprogram body is + -- appended to it (case where the RACW declaration is in the main unit). + + procedure Add_RACW_Write_Attribute + (RACW_Type : Entity_Id; + Stub_Type : Entity_Id; + Stub_Type_Access : Entity_Id; + Body_Decls : List_Id); + -- Same as above for the Write attribute + + procedure Add_RACW_From_Any + (RACW_Type : Entity_Id; + Body_Decls : List_Id); + -- Add the From_Any TSS for this RACW type + + procedure Add_RACW_To_Any + (RACW_Type : Entity_Id; + Body_Decls : List_Id); + -- Add the To_Any TSS for this RACW type + + procedure Add_RACW_TypeCode + (Designated_Type : Entity_Id; + RACW_Type : Entity_Id; + Body_Decls : List_Id); + -- Add the TypeCode TSS for this RACW type + + procedure Add_RAS_From_Any (RAS_Type : Entity_Id); + -- Add the From_Any TSS for this RAS type + + procedure Add_RAS_To_Any (RAS_Type : Entity_Id); + -- Add the To_Any TSS for this RAS type + + procedure Add_RAS_TypeCode (RAS_Type : Entity_Id); + -- Add the TypeCode TSS for this RAS type + + procedure Add_RAS_Access_TSS (N : Node_Id); + -- Add a subprogram body for RAS Access TSS + + ------------------------------------- + -- Add_Obj_RPC_Receiver_Completion -- + ------------------------------------- + + procedure Add_Obj_RPC_Receiver_Completion + (Loc : Source_Ptr; + Decls : List_Id; + RPC_Receiver : Entity_Id; + Stub_Elements : Stub_Structure) + is + Desig : constant Entity_Id := + Etype (Designated_Type (Stub_Elements.RACW_Type)); + begin + Append_To (Decls, + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of ( + RTE (RE_Register_Obj_Receiving_Stub), Loc), + + Parameter_Associations => New_List ( + + -- Name + + Make_String_Literal (Loc, + Fully_Qualified_Name_String (Desig)), + + -- Handler + + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of ( + Defining_Unit_Name (Parent (RPC_Receiver)), Loc), + Attribute_Name => + Name_Access), + + -- Receiver + + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of ( + Defining_Identifier ( + Stub_Elements.RPC_Receiver_Decl), Loc), + Attribute_Name => + Name_Access)))); + end Add_Obj_RPC_Receiver_Completion; + + ----------------------- + -- Add_RACW_Features -- + ----------------------- + + procedure Add_RACW_Features + (RACW_Type : Entity_Id; + Desig : Entity_Id; + Stub_Type : Entity_Id; + Stub_Type_Access : Entity_Id; + RPC_Receiver_Decl : Node_Id; + Body_Decls : List_Id) + is + pragma Unreferenced (RPC_Receiver_Decl); + + begin + Add_RACW_From_Any + (RACW_Type => RACW_Type, + Body_Decls => Body_Decls); + + Add_RACW_To_Any + (RACW_Type => RACW_Type, + Body_Decls => Body_Decls); + + Add_RACW_Write_Attribute + (RACW_Type => RACW_Type, + Stub_Type => Stub_Type, + Stub_Type_Access => Stub_Type_Access, + Body_Decls => Body_Decls); + + Add_RACW_Read_Attribute + (RACW_Type => RACW_Type, + Stub_Type => Stub_Type, + Stub_Type_Access => Stub_Type_Access, + Body_Decls => Body_Decls); + + Add_RACW_TypeCode + (Designated_Type => Desig, + RACW_Type => RACW_Type, + Body_Decls => Body_Decls); + end Add_RACW_Features; + + ----------------------- + -- Add_RACW_From_Any -- + ----------------------- + + procedure Add_RACW_From_Any + (RACW_Type : Entity_Id; + Body_Decls : List_Id) + is + Loc : constant Source_Ptr := Sloc (RACW_Type); + Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type); + Fnam : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (RACW_Type), 'F')); + + Func_Spec : Node_Id; + Func_Decl : Node_Id; + Func_Body : Node_Id; + + Statements : List_Id; + -- Various parts of the subprogram + + Any_Parameter : constant Entity_Id := + Make_Defining_Identifier (Loc, Name_A); + + Asynchronous_Flag : constant Entity_Id := + Asynchronous_Flags_Table.Get (RACW_Type); + -- The flag object declared in Add_RACW_Asynchronous_Flag + + begin + Func_Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => + Fnam, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Any_Parameter, + Parameter_Type => + New_Occurrence_Of (RTE (RE_Any), Loc))), + Result_Definition => New_Occurrence_Of (RACW_Type, Loc)); + + -- NOTE: The usage occurrences of RACW_Parameter must refer to the + -- entity in the declaration spec, not those of the body spec. + + Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec); + Insert_After (Declaration_Node (RACW_Type), Func_Decl); + Set_Renaming_TSS (RACW_Type, Fnam, TSS_From_Any); + + if No (Body_Decls) then + return; + end if; + + -- ??? Issue with asynchronous calls here: the Asynchronous flag is + -- set on the stub type if, and only if, the RACW type has a pragma + -- Asynchronous. This is incorrect for RACWs that implement RAS + -- types, because in that case the /designated subprogram/ (not the + -- type) might be asynchronous, and that causes the stub to need to + -- be asynchronous too. A solution is to transport a RAS as a struct + -- containing a RACW and an asynchronous flag, and to properly alter + -- the Asynchronous component in the stub type in the RAS's _From_Any + -- TSS. + + Statements := New_List ( + Make_Simple_Return_Statement (Loc, + Expression => Unchecked_Convert_To (RACW_Type, + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (RE_Get_RACW), Loc), + Parameter_Associations => New_List ( + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (RE_FA_ObjRef), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Any_Parameter, Loc))), + Build_Stub_Tag (Loc, RACW_Type), + New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc), + New_Occurrence_Of (Asynchronous_Flag, Loc)))))); + + Func_Body := + Make_Subprogram_Body (Loc, + Specification => Copy_Specification (Loc, Func_Spec), + Declarations => No_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Statements)); + + Append_To (Body_Decls, Func_Body); + end Add_RACW_From_Any; + + ----------------------------- + -- Add_RACW_Read_Attribute -- + ----------------------------- + + procedure Add_RACW_Read_Attribute + (RACW_Type : Entity_Id; + Stub_Type : Entity_Id; + Stub_Type_Access : Entity_Id; + Body_Decls : List_Id) + is + pragma Unreferenced (Stub_Type, Stub_Type_Access); + + Loc : constant Source_Ptr := Sloc (RACW_Type); + + Proc_Decl : Node_Id; + Attr_Decl : Node_Id; + + Body_Node : Node_Id; + + Decls : constant List_Id := New_List; + Statements : constant List_Id := New_List; + Reference : constant Entity_Id := + Make_Defining_Identifier (Loc, Name_R); + -- Various parts of the procedure + + Pnam : constant Entity_Id := Make_Temporary (Loc, 'R'); + + Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type); + + Asynchronous_Flag : constant Entity_Id := + Asynchronous_Flags_Table.Get (RACW_Type); + pragma Assert (Present (Asynchronous_Flag)); + + function Stream_Parameter return Node_Id; + function Result return Node_Id; + + -- Functions to create occurrences of the formal parameter names + + ------------ + -- Result -- + ------------ + + function Result return Node_Id is + begin + return Make_Identifier (Loc, Name_V); + end Result; + + ---------------------- + -- Stream_Parameter -- + ---------------------- + + function Stream_Parameter return Node_Id is + begin + return Make_Identifier (Loc, Name_S); + end Stream_Parameter; + + -- Start of processing for Add_RACW_Read_Attribute + + begin + Build_Stream_Procedure + (Loc, RACW_Type, Body_Node, Pnam, Statements, Outp => True); + + Proc_Decl := Make_Subprogram_Declaration (Loc, + Copy_Specification (Loc, Specification (Body_Node))); + + Attr_Decl := + Make_Attribute_Definition_Clause (Loc, + Name => New_Occurrence_Of (RACW_Type, Loc), + Chars => Name_Read, + Expression => + New_Occurrence_Of ( + Defining_Unit_Name (Specification (Proc_Decl)), Loc)); + + Insert_After (Declaration_Node (RACW_Type), Proc_Decl); + Insert_After (Proc_Decl, Attr_Decl); + + if No (Body_Decls) then + return; + end if; + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => + Reference, + Object_Definition => + New_Occurrence_Of (RTE (RE_Object_Ref), Loc))); + + Append_List_To (Statements, New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (RTE (RE_Object_Ref), Loc), + Attribute_Name => Name_Read, + Expressions => New_List ( + Stream_Parameter, + New_Occurrence_Of (Reference, Loc))), + + Make_Assignment_Statement (Loc, + Name => + Result, + Expression => + Unchecked_Convert_To (RACW_Type, + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (RTE (RE_Get_RACW), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Reference, Loc), + Build_Stub_Tag (Loc, RACW_Type), + New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc), + New_Occurrence_Of (Asynchronous_Flag, Loc))))))); + + Set_Declarations (Body_Node, Decls); + Append_To (Body_Decls, Body_Node); + end Add_RACW_Read_Attribute; + + --------------------- + -- Add_RACW_To_Any -- + --------------------- + + procedure Add_RACW_To_Any + (RACW_Type : Entity_Id; + Body_Decls : List_Id) + is + Loc : constant Source_Ptr := Sloc (RACW_Type); + + Fnam : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (RACW_Type), 'T')); + + Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type); + + Stub_Elements : constant Stub_Structure := + Get_Stub_Elements (RACW_Type); + + Func_Spec : Node_Id; + Func_Decl : Node_Id; + Func_Body : Node_Id; + + Decls : List_Id; + Statements : List_Id; + -- Various parts of the subprogram + + RACW_Parameter : constant Entity_Id := + Make_Defining_Identifier (Loc, Name_R); + + Reference : constant Entity_Id := Make_Temporary (Loc, 'R'); + Any : constant Entity_Id := Make_Temporary (Loc, 'A'); + + begin + Func_Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => + Fnam, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + RACW_Parameter, + Parameter_Type => + New_Occurrence_Of (RACW_Type, Loc))), + Result_Definition => New_Occurrence_Of (RTE (RE_Any), Loc)); + + -- NOTE: The usage occurrences of RACW_Parameter must refer to the + -- entity in the declaration spec, not in the body spec. + + Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec); + + Insert_After (Declaration_Node (RACW_Type), Func_Decl); + Set_Renaming_TSS (RACW_Type, Fnam, TSS_To_Any); + + if No (Body_Decls) then + return; + end if; + + -- Generate: + + -- R : constant Object_Ref := + -- Get_Reference + -- (Address!(RACW), + -- "typ", + -- Stub_Type'Tag, + -- Is_RAS, + -- RPC_Receiver'Access); + -- A : Any; + + Decls := New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => Reference, + Constant_Present => True, + Object_Definition => + New_Occurrence_Of (RTE (RE_Object_Ref), Loc), + Expression => + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (RE_Get_Reference), Loc), + Parameter_Associations => New_List ( + Unchecked_Convert_To (RTE (RE_Address), + New_Occurrence_Of (RACW_Parameter, Loc)), + Make_String_Literal (Loc, + Strval => Fully_Qualified_Name_String + (Etype (Designated_Type (RACW_Type)))), + Build_Stub_Tag (Loc, RACW_Type), + New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc), + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of + (Defining_Identifier + (Stub_Elements.RPC_Receiver_Decl), Loc), + Attribute_Name => Name_Access)))), + + Make_Object_Declaration (Loc, + Defining_Identifier => Any, + Object_Definition => New_Occurrence_Of (RTE (RE_Any), Loc))); + + -- Generate: + + -- Any := TA_ObjRef (Reference); + -- Set_TC (Any, RPC_Receiver.Obj_TypeCode); + -- return Any; + + Statements := New_List ( + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Any, Loc), + Expression => + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (RE_TA_ObjRef), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Reference, Loc)))), + + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (RTE (RE_Set_TC), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Any, Loc), + Make_Selected_Component (Loc, + Prefix => + Defining_Identifier ( + Stub_Elements.RPC_Receiver_Decl), + Selector_Name => Name_Obj_TypeCode))), + + Make_Simple_Return_Statement (Loc, + Expression => New_Occurrence_Of (Any, Loc))); + + Func_Body := + Make_Subprogram_Body (Loc, + Specification => Copy_Specification (Loc, Func_Spec), + Declarations => Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Statements)); + Append_To (Body_Decls, Func_Body); + end Add_RACW_To_Any; + + ----------------------- + -- Add_RACW_TypeCode -- + ----------------------- + + procedure Add_RACW_TypeCode + (Designated_Type : Entity_Id; + RACW_Type : Entity_Id; + Body_Decls : List_Id) + is + Loc : constant Source_Ptr := Sloc (RACW_Type); + + Fnam : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (RACW_Type), 'Y')); + + Stub_Elements : constant Stub_Structure := + Stubs_Table.Get (Designated_Type); + pragma Assert (Stub_Elements /= Empty_Stub_Structure); + + Func_Spec : Node_Id; + Func_Decl : Node_Id; + Func_Body : Node_Id; + + begin + -- The spec for this subprogram has a dummy 'access RACW' argument, + -- which serves only for overloading purposes. + + Func_Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => Fnam, + Result_Definition => New_Occurrence_Of (RTE (RE_TypeCode), Loc)); + + -- NOTE: The usage occurrences of RACW_Parameter must refer to the + -- entity in the declaration spec, not those of the body spec. + + Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec); + Insert_After (Declaration_Node (RACW_Type), Func_Decl); + Set_Renaming_TSS (RACW_Type, Fnam, TSS_TypeCode); + + if No (Body_Decls) then + return; + end if; + + Func_Body := + Make_Subprogram_Body (Loc, + Specification => Copy_Specification (Loc, Func_Spec), + Declarations => Empty_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Simple_Return_Statement (Loc, + Expression => + Make_Selected_Component (Loc, + Prefix => + Defining_Identifier + (Stub_Elements.RPC_Receiver_Decl), + Selector_Name => Name_Obj_TypeCode))))); + + Append_To (Body_Decls, Func_Body); + end Add_RACW_TypeCode; + + ------------------------------ + -- Add_RACW_Write_Attribute -- + ------------------------------ + + procedure Add_RACW_Write_Attribute + (RACW_Type : Entity_Id; + Stub_Type : Entity_Id; + Stub_Type_Access : Entity_Id; + Body_Decls : List_Id) + is + pragma Unreferenced (Stub_Type, Stub_Type_Access); + + Loc : constant Source_Ptr := Sloc (RACW_Type); + + Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type); + + Stub_Elements : constant Stub_Structure := + Get_Stub_Elements (RACW_Type); + + Body_Node : Node_Id; + Proc_Decl : Node_Id; + Attr_Decl : Node_Id; + + Statements : constant List_Id := New_List; + Pnam : constant Entity_Id := Make_Temporary (Loc, 'R'); + + function Stream_Parameter return Node_Id; + function Object return Node_Id; + -- Functions to create occurrences of the formal parameter names + + ------------ + -- Object -- + ------------ + + function Object return Node_Id is + begin + return Make_Identifier (Loc, Name_V); + end Object; + + ---------------------- + -- Stream_Parameter -- + ---------------------- + + function Stream_Parameter return Node_Id is + begin + return Make_Identifier (Loc, Name_S); + end Stream_Parameter; + + -- Start of processing for Add_RACW_Write_Attribute + + begin + Build_Stream_Procedure + (Loc, RACW_Type, Body_Node, Pnam, Statements, Outp => False); + + Proc_Decl := + Make_Subprogram_Declaration (Loc, + Copy_Specification (Loc, Specification (Body_Node))); + + Attr_Decl := + Make_Attribute_Definition_Clause (Loc, + Name => New_Occurrence_Of (RACW_Type, Loc), + Chars => Name_Write, + Expression => + New_Occurrence_Of ( + Defining_Unit_Name (Specification (Proc_Decl)), Loc)); + + Insert_After (Declaration_Node (RACW_Type), Proc_Decl); + Insert_After (Proc_Decl, Attr_Decl); + + if No (Body_Decls) then + return; + end if; + + Append_To (Statements, + Pack_Node_Into_Stream_Access (Loc, + Stream => Stream_Parameter, + Object => + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (RE_Get_Reference), Loc), + Parameter_Associations => New_List ( + Unchecked_Convert_To (RTE (RE_Address), Object), + Make_String_Literal (Loc, + Strval => Fully_Qualified_Name_String + (Etype (Designated_Type (RACW_Type)))), + Build_Stub_Tag (Loc, RACW_Type), + New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc), + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of + (Defining_Identifier + (Stub_Elements.RPC_Receiver_Decl), Loc), + Attribute_Name => Name_Access))), + + Etyp => RTE (RE_Object_Ref))); + + Append_To (Body_Decls, Body_Node); + end Add_RACW_Write_Attribute; + + ----------------------- + -- Add_RAST_Features -- + ----------------------- + + procedure Add_RAST_Features + (Vis_Decl : Node_Id; + RAS_Type : Entity_Id) + is + begin + Add_RAS_Access_TSS (Vis_Decl); + + Add_RAS_From_Any (RAS_Type); + Add_RAS_TypeCode (RAS_Type); + + -- To_Any uses TypeCode, and therefore needs to be generated last + + Add_RAS_To_Any (RAS_Type); + end Add_RAST_Features; + + ------------------------ + -- Add_RAS_Access_TSS -- + ------------------------ + + procedure Add_RAS_Access_TSS (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + + Ras_Type : constant Entity_Id := Defining_Identifier (N); + Fat_Type : constant Entity_Id := Equivalent_Type (Ras_Type); + -- Ras_Type is the access to subprogram type; Fat_Type is the + -- corresponding record type. + + RACW_Type : constant Entity_Id := + Underlying_RACW_Type (Ras_Type); + + Stub_Elements : constant Stub_Structure := + Get_Stub_Elements (RACW_Type); + + Proc : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => Make_TSS_Name (Ras_Type, TSS_RAS_Access)); + + Proc_Spec : Node_Id; + + -- Formal parameters + + Package_Name : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => Name_P); + + -- Target package + + Subp_Id : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => Name_S); + + -- Target subprogram + + Asynch_P : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => Name_Asynchronous); + -- Is the procedure to which the 'Access applies asynchronous? + + All_Calls_Remote : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => Name_All_Calls_Remote); + -- True if an All_Calls_Remote pragma applies to the RCI unit + -- that contains the subprogram. + + -- Common local variables + + Proc_Decls : List_Id; + Proc_Statements : List_Id; + + Subp_Ref : constant Entity_Id := + Make_Defining_Identifier (Loc, Name_R); + -- Reference that designates the target subprogram (returned + -- by Get_RAS_Info). + + Is_Local : constant Entity_Id := + Make_Defining_Identifier (Loc, Name_L); + Local_Addr : constant Entity_Id := + Make_Defining_Identifier (Loc, Name_A); + -- For the call to Get_Local_Address + + Local_Stub : constant Entity_Id := Make_Temporary (Loc, 'L'); + Stub_Ptr : constant Entity_Id := Make_Temporary (Loc, 'S'); + -- Additional local variables for the remote case + + function Set_Field + (Field_Name : Name_Id; + Value : Node_Id) return Node_Id; + -- Construct an assignment that sets the named component in the + -- returned record + + --------------- + -- Set_Field -- + --------------- + + function Set_Field + (Field_Name : Name_Id; + Value : Node_Id) return Node_Id + is + begin + return + Make_Assignment_Statement (Loc, + Name => + Make_Selected_Component (Loc, + Prefix => Stub_Ptr, + Selector_Name => Field_Name), + Expression => Value); + end Set_Field; + + -- Start of processing for Add_RAS_Access_TSS + + begin + Proc_Decls := New_List ( + + -- Common declarations + + Make_Object_Declaration (Loc, + Defining_Identifier => Subp_Ref, + Object_Definition => + New_Occurrence_Of (RTE (RE_Object_Ref), Loc)), + + Make_Object_Declaration (Loc, + Defining_Identifier => Is_Local, + Object_Definition => + New_Occurrence_Of (Standard_Boolean, Loc)), + + Make_Object_Declaration (Loc, + Defining_Identifier => Local_Addr, + Object_Definition => + New_Occurrence_Of (RTE (RE_Address), Loc)), + + Make_Object_Declaration (Loc, + Defining_Identifier => Local_Stub, + Aliased_Present => True, + Object_Definition => + New_Occurrence_Of (Stub_Elements.Stub_Type, Loc)), + + Make_Object_Declaration (Loc, + Defining_Identifier => Stub_Ptr, + Object_Definition => + New_Occurrence_Of (Stub_Elements.Stub_Type_Access, Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Local_Stub, Loc), + Attribute_Name => Name_Unchecked_Access))); + + Set_Etype (Stub_Ptr, Stub_Elements.Stub_Type_Access); + -- Build_Get_Unique_RP_Call needs this information + + -- Get_RAS_Info (Pkg, Subp, R); + -- Obtain a reference to the target subprogram + + Proc_Statements := New_List ( + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (RTE (RE_Get_RAS_Info), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Package_Name, Loc), + New_Occurrence_Of (Subp_Id, Loc), + New_Occurrence_Of (Subp_Ref, Loc))), + + -- Get_Local_Address (R, L, A); + -- Determine whether the subprogram is local (L), and if so + -- obtain the local address of its proxy (A). + + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Subp_Ref, Loc), + New_Occurrence_Of (Is_Local, Loc), + New_Occurrence_Of (Local_Addr, Loc)))); + + -- Note: Here we assume that the Fat_Type is a record containing just + -- an access to a proxy or stub object. + + Append_To (Proc_Statements, + + -- if L then + + Make_Implicit_If_Statement (N, + Condition => New_Occurrence_Of (Is_Local, Loc), + + Then_Statements => New_List ( + + -- if A.Target = null then + + Make_Implicit_If_Statement (N, + Condition => + Make_Op_Eq (Loc, + Make_Selected_Component (Loc, + Prefix => + Unchecked_Convert_To + (RTE (RE_RAS_Proxy_Type_Access), + New_Occurrence_Of (Local_Addr, Loc)), + Selector_Name => Make_Identifier (Loc, Name_Target)), + Make_Null (Loc)), + + Then_Statements => New_List ( + + -- A.Target := Entity_Of (Ref); + + Make_Assignment_Statement (Loc, + Name => + Make_Selected_Component (Loc, + Prefix => + Unchecked_Convert_To + (RTE (RE_RAS_Proxy_Type_Access), + New_Occurrence_Of (Local_Addr, Loc)), + Selector_Name => Make_Identifier (Loc, Name_Target)), + Expression => + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (RE_Entity_Of), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Subp_Ref, Loc)))), + + -- Inc_Usage (A.Target); + -- end if; + + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (RTE (RE_Inc_Usage), Loc), + Parameter_Associations => New_List ( + Make_Selected_Component (Loc, + Prefix => + Unchecked_Convert_To + (RTE (RE_RAS_Proxy_Type_Access), + New_Occurrence_Of (Local_Addr, Loc)), + Selector_Name => + Make_Identifier (Loc, Name_Target)))))), + + -- if not All_Calls_Remote then + -- return Fat_Type!(A); + -- end if; + + Make_Implicit_If_Statement (N, + Condition => + Make_Op_Not (Loc, + Right_Opnd => + New_Occurrence_Of (All_Calls_Remote, Loc)), + + Then_Statements => New_List ( + Make_Simple_Return_Statement (Loc, + Expression => + Unchecked_Convert_To + (Fat_Type, New_Occurrence_Of (Local_Addr, Loc)))))))); + + Append_List_To (Proc_Statements, New_List ( + + -- Stub.Target := Entity_Of (Ref); + + Set_Field (Name_Target, + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (RE_Entity_Of), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Subp_Ref, Loc)))), + + -- Inc_Usage (Stub.Target); + + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (RTE (RE_Inc_Usage), Loc), + Parameter_Associations => New_List ( + Make_Selected_Component (Loc, + Prefix => Stub_Ptr, + Selector_Name => Name_Target))), + + -- E.4.1(9) A remote call is asynchronous if it is a call to + -- a procedure, or a call through a value of an access-to-procedure + -- type, to which a pragma Asynchronous applies. + + -- Parameter Asynch_P is true when the procedure is asynchronous; + -- Expression Asynch_T is true when the type is asynchronous. + + Set_Field (Name_Asynchronous, + Make_Or_Else (Loc, + Left_Opnd => New_Occurrence_Of (Asynch_P, Loc), + Right_Opnd => + New_Occurrence_Of + (Boolean_Literals (Is_Asynchronous (Ras_Type)), Loc))))); + + Append_List_To (Proc_Statements, + Build_Get_Unique_RP_Call (Loc, Stub_Ptr, Stub_Elements.Stub_Type)); + + Append_To (Proc_Statements, + Make_Simple_Return_Statement (Loc, + Expression => + Unchecked_Convert_To (Fat_Type, + New_Occurrence_Of (Stub_Ptr, Loc)))); + + Proc_Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => Proc, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Package_Name, + Parameter_Type => + New_Occurrence_Of (Standard_String, Loc)), + + Make_Parameter_Specification (Loc, + Defining_Identifier => Subp_Id, + Parameter_Type => + New_Occurrence_Of (Standard_String, Loc)), + + Make_Parameter_Specification (Loc, + Defining_Identifier => Asynch_P, + Parameter_Type => + New_Occurrence_Of (Standard_Boolean, Loc)), + + Make_Parameter_Specification (Loc, + Defining_Identifier => All_Calls_Remote, + Parameter_Type => + New_Occurrence_Of (Standard_Boolean, Loc))), + + Result_Definition => + New_Occurrence_Of (Fat_Type, Loc)); + + -- Set the kind and return type of the function to prevent + -- ambiguities between Ras_Type and Fat_Type in subsequent analysis. + + Set_Ekind (Proc, E_Function); + Set_Etype (Proc, Fat_Type); + + Discard_Node ( + Make_Subprogram_Body (Loc, + Specification => Proc_Spec, + Declarations => Proc_Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Proc_Statements))); + + Set_TSS (Fat_Type, Proc); + end Add_RAS_Access_TSS; + + ---------------------- + -- Add_RAS_From_Any -- + ---------------------- + + procedure Add_RAS_From_Any (RAS_Type : Entity_Id) is + Loc : constant Source_Ptr := Sloc (RAS_Type); + + Fnam : constant Entity_Id := Make_Defining_Identifier (Loc, + Make_TSS_Name (RAS_Type, TSS_From_Any)); + + Func_Spec : Node_Id; + + Statements : List_Id; + + Any_Parameter : constant Entity_Id := + Make_Defining_Identifier (Loc, Name_A); + + begin + Statements := New_List ( + Make_Simple_Return_Statement (Loc, + Expression => + Make_Aggregate (Loc, + Component_Associations => New_List ( + Make_Component_Association (Loc, + Choices => New_List (Make_Identifier (Loc, Name_Ras)), + Expression => + PolyORB_Support.Helpers.Build_From_Any_Call + (Underlying_RACW_Type (RAS_Type), + New_Occurrence_Of (Any_Parameter, Loc), + No_List)))))); + + Func_Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => Fnam, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Any_Parameter, + Parameter_Type => New_Occurrence_Of (RTE (RE_Any), Loc))), + Result_Definition => New_Occurrence_Of (RAS_Type, Loc)); + + Discard_Node ( + Make_Subprogram_Body (Loc, + Specification => Func_Spec, + Declarations => No_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Statements))); + Set_TSS (RAS_Type, Fnam); + end Add_RAS_From_Any; + + -------------------- + -- Add_RAS_To_Any -- + -------------------- + + procedure Add_RAS_To_Any (RAS_Type : Entity_Id) is + Loc : constant Source_Ptr := Sloc (RAS_Type); + + Fnam : constant Entity_Id := Make_Defining_Identifier (Loc, + Make_TSS_Name (RAS_Type, TSS_To_Any)); + + Decls : List_Id; + Statements : List_Id; + + Func_Spec : Node_Id; + + Any : constant Entity_Id := Make_Temporary (Loc, 'A'); + RAS_Parameter : constant Entity_Id := Make_Temporary (Loc, 'R'); + RACW_Parameter : constant Node_Id := + Make_Selected_Component (Loc, + Prefix => RAS_Parameter, + Selector_Name => Name_Ras); + + begin + -- Object declarations + + Set_Etype (RACW_Parameter, Underlying_RACW_Type (RAS_Type)); + Decls := New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => Any, + Object_Definition => New_Occurrence_Of (RTE (RE_Any), Loc), + Expression => + PolyORB_Support.Helpers.Build_To_Any_Call + (Loc, RACW_Parameter, No_List))); + + Statements := New_List ( + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (RTE (RE_Set_TC), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Any, Loc), + PolyORB_Support.Helpers.Build_TypeCode_Call (Loc, + RAS_Type, Decls))), + + Make_Simple_Return_Statement (Loc, + Expression => New_Occurrence_Of (Any, Loc))); + + Func_Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => Fnam, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => RAS_Parameter, + Parameter_Type => New_Occurrence_Of (RAS_Type, Loc))), + Result_Definition => New_Occurrence_Of (RTE (RE_Any), Loc)); + + Discard_Node ( + Make_Subprogram_Body (Loc, + Specification => Func_Spec, + Declarations => Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Statements))); + Set_TSS (RAS_Type, Fnam); + end Add_RAS_To_Any; + + ---------------------- + -- Add_RAS_TypeCode -- + ---------------------- + + procedure Add_RAS_TypeCode (RAS_Type : Entity_Id) is + Loc : constant Source_Ptr := Sloc (RAS_Type); + + Fnam : constant Entity_Id := Make_Defining_Identifier (Loc, + Make_TSS_Name (RAS_Type, TSS_TypeCode)); + + Func_Spec : Node_Id; + Decls : constant List_Id := New_List; + Name_String : String_Id; + Repo_Id_String : String_Id; + + begin + Func_Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => Fnam, + Result_Definition => New_Occurrence_Of (RTE (RE_TypeCode), Loc)); + + PolyORB_Support.Helpers.Build_Name_And_Repository_Id + (RAS_Type, Name_Str => Name_String, Repo_Id_Str => Repo_Id_String); + + Discard_Node ( + Make_Subprogram_Body (Loc, + Specification => Func_Spec, + Declarations => Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Simple_Return_Statement (Loc, + Expression => + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (RE_TC_Build), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (RTE (RE_TC_Object), Loc), + Make_Aggregate (Loc, + Expressions => + New_List ( + Make_Function_Call (Loc, + Name => + New_Occurrence_Of + (RTE (RE_TA_Std_String), Loc), + Parameter_Associations => New_List ( + Make_String_Literal (Loc, Name_String))), + Make_Function_Call (Loc, + Name => + New_Occurrence_Of + (RTE (RE_TA_Std_String), Loc), + Parameter_Associations => New_List ( + Make_String_Literal (Loc, + Strval => Repo_Id_String)))))))))))); + Set_TSS (RAS_Type, Fnam); + end Add_RAS_TypeCode; + + ----------------------------------------- + -- Add_Receiving_Stubs_To_Declarations -- + ----------------------------------------- + + procedure Add_Receiving_Stubs_To_Declarations + (Pkg_Spec : Node_Id; + Decls : List_Id; + Stmts : List_Id) + is + Loc : constant Source_Ptr := Sloc (Pkg_Spec); + + Pkg_RPC_Receiver : constant Entity_Id := + Make_Temporary (Loc, 'H'); + Pkg_RPC_Receiver_Object : Node_Id; + Pkg_RPC_Receiver_Body : Node_Id; + Pkg_RPC_Receiver_Decls : List_Id; + Pkg_RPC_Receiver_Statements : List_Id; + + Pkg_RPC_Receiver_Cases : constant List_Id := New_List; + -- A Pkg_RPC_Receiver is built to decode the request + + Request : Node_Id; + -- Request object received from neutral layer + + Subp_Id : Entity_Id; + -- Subprogram identifier as received from the neutral distribution + -- core. + + Subp_Index : Entity_Id; + -- Internal index as determined by matching either the method name + -- from the request structure, or the local subprogram address (in + -- case of a RAS). + + Is_Local : constant Entity_Id := Make_Temporary (Loc, 'L'); + + Local_Address : constant Entity_Id := Make_Temporary (Loc, 'A'); + -- Address of a local subprogram designated by a reference + -- corresponding to a RAS. + + Dispatch_On_Address : constant List_Id := New_List; + Dispatch_On_Name : constant List_Id := New_List; + + Current_Subp_Number : Int := First_RCI_Subprogram_Id; + + Subp_Info_Array : constant Entity_Id := Make_Temporary (Loc, 'I'); + Subp_Info_List : constant List_Id := New_List; + + Register_Pkg_Actuals : constant List_Id := New_List; + + All_Calls_Remote_E : Entity_Id; + + procedure Append_Stubs_To + (RPC_Receiver_Cases : List_Id; + Declaration : Node_Id; + Stubs : Node_Id; + Subp_Number : Int; + Subp_Dist_Name : Entity_Id; + Subp_Proxy_Addr : Entity_Id); + -- Add one case to the specified RPC receiver case list associating + -- Subprogram_Number with the subprogram declared by Declaration, for + -- which we have receiving stubs in Stubs. Subp_Number is an internal + -- subprogram index. Subp_Dist_Name is the string used to call the + -- subprogram by name, and Subp_Dist_Addr is the address of the proxy + -- object, used in the context of calls through remote + -- access-to-subprogram types. + + procedure Visit_Subprogram (Decl : Node_Id); + -- Generate receiving stub for one remote subprogram + + --------------------- + -- Append_Stubs_To -- + --------------------- + + procedure Append_Stubs_To + (RPC_Receiver_Cases : List_Id; + Declaration : Node_Id; + Stubs : Node_Id; + Subp_Number : Int; + Subp_Dist_Name : Entity_Id; + Subp_Proxy_Addr : Entity_Id) + is + Case_Stmts : List_Id; + begin + Case_Stmts := New_List ( + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of ( + Defining_Entity (Stubs), Loc), + Parameter_Associations => + New_List (New_Occurrence_Of (Request, Loc)))); + + if Nkind (Specification (Declaration)) = N_Function_Specification + or else not + Is_Asynchronous (Defining_Entity (Specification (Declaration))) + then + Append_To (Case_Stmts, Make_Simple_Return_Statement (Loc)); + end if; + + Append_To (RPC_Receiver_Cases, + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => + New_List (Make_Integer_Literal (Loc, Subp_Number)), + Statements => Case_Stmts)); + + Append_To (Dispatch_On_Name, + Make_Elsif_Part (Loc, + Condition => + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (RTE (RE_Caseless_String_Eq), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Subp_Id, Loc), + New_Occurrence_Of (Subp_Dist_Name, Loc))), + + Then_Statements => New_List ( + Make_Assignment_Statement (Loc, + New_Occurrence_Of (Subp_Index, Loc), + Make_Integer_Literal (Loc, Subp_Number))))); + + Append_To (Dispatch_On_Address, + Make_Elsif_Part (Loc, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => New_Occurrence_Of (Local_Address, Loc), + Right_Opnd => New_Occurrence_Of (Subp_Proxy_Addr, Loc)), + + Then_Statements => New_List ( + Make_Assignment_Statement (Loc, + New_Occurrence_Of (Subp_Index, Loc), + Make_Integer_Literal (Loc, Subp_Number))))); + end Append_Stubs_To; + + ---------------------- + -- Visit_Subprogram -- + ---------------------- + + procedure Visit_Subprogram (Decl : Node_Id) is + Loc : constant Source_Ptr := Sloc (Decl); + Spec : constant Node_Id := Specification (Decl); + Subp_Def : constant Entity_Id := Defining_Unit_Name (Spec); + + Subp_Val : String_Id; + + Subp_Dist_Name : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => + New_External_Name + (Related_Id => Chars (Subp_Def), + Suffix => 'D', + Suffix_Index => -1)); + + Current_Stubs : Node_Id; + Proxy_Obj_Addr : Entity_Id; + + begin + -- Disable expansion of stubs if serious errors have been + -- diagnosed, because otherwise some illegal remote subprogram + -- declarations could cause cascaded errors in stubs. + + if Serious_Errors_Detected /= 0 then + return; + end if; + + -- Build receiving stub + + Current_Stubs := + Build_Subprogram_Receiving_Stubs + (Vis_Decl => Decl, + Asynchronous => Nkind (Spec) = N_Procedure_Specification + and then Is_Asynchronous (Subp_Def)); + + Append_To (Decls, Current_Stubs); + Analyze (Current_Stubs); + + -- Build RAS proxy + + Add_RAS_Proxy_And_Analyze (Decls, + Vis_Decl => Decl, + All_Calls_Remote_E => All_Calls_Remote_E, + Proxy_Object_Addr => Proxy_Obj_Addr); + + -- Compute distribution identifier + + Assign_Subprogram_Identifier + (Subp_Def, Current_Subp_Number, Subp_Val); + + pragma Assert + (Current_Subp_Number = Get_Subprogram_Id (Subp_Def)); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Subp_Dist_Name, + Constant_Present => True, + Object_Definition => + New_Occurrence_Of (Standard_String, Loc), + Expression => + Make_String_Literal (Loc, Subp_Val))); + Analyze (Last (Decls)); + + -- Add subprogram descriptor (RCI_Subp_Info) to the subprograms + -- table for this receiver. The aggregate below must be kept + -- consistent with the declaration of RCI_Subp_Info in + -- System.Partition_Interface. + + Append_To (Subp_Info_List, + Make_Component_Association (Loc, + Choices => + New_List (Make_Integer_Literal (Loc, Current_Subp_Number)), + + Expression => + Make_Aggregate (Loc, + Expressions => New_List ( + + -- Name => + + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Subp_Dist_Name, Loc), + Attribute_Name => Name_Address), + + -- Name_Length => + + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Subp_Dist_Name, Loc), + Attribute_Name => Name_Length), + + -- Addr => + + New_Occurrence_Of (Proxy_Obj_Addr, Loc))))); + + Append_Stubs_To (Pkg_RPC_Receiver_Cases, + Declaration => Decl, + Stubs => Current_Stubs, + Subp_Number => Current_Subp_Number, + Subp_Dist_Name => Subp_Dist_Name, + Subp_Proxy_Addr => Proxy_Obj_Addr); + + Current_Subp_Number := Current_Subp_Number + 1; + end Visit_Subprogram; + + procedure Visit_Spec is new Build_Package_Stubs (Visit_Subprogram); + + -- Start of processing for Add_Receiving_Stubs_To_Declarations + + begin + -- Building receiving stubs consist in several operations: + + -- - a package RPC receiver must be built. This subprogram will get + -- a Subprogram_Id from the incoming stream and will dispatch the + -- call to the right subprogram; + + -- - a receiving stub for each subprogram visible in the package + -- spec. This stub will read all the parameters from the stream, + -- and put the result as well as the exception occurrence in the + -- output stream; + + Build_RPC_Receiver_Body ( + RPC_Receiver => Pkg_RPC_Receiver, + Request => Request, + Subp_Id => Subp_Id, + Subp_Index => Subp_Index, + Stmts => Pkg_RPC_Receiver_Statements, + Decl => Pkg_RPC_Receiver_Body); + Pkg_RPC_Receiver_Decls := Declarations (Pkg_RPC_Receiver_Body); + + -- Extract local address information from the target reference: + -- if non-null, that means that this is a reference that denotes + -- one particular operation, and hence that the operation name + -- must not be taken into account for dispatching. + + Append_To (Pkg_RPC_Receiver_Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Is_Local, + Object_Definition => + New_Occurrence_Of (Standard_Boolean, Loc))); + + Append_To (Pkg_RPC_Receiver_Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Local_Address, + Object_Definition => + New_Occurrence_Of (RTE (RE_Address), Loc))); + + Append_To (Pkg_RPC_Receiver_Statements, + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc), + Parameter_Associations => New_List ( + Make_Selected_Component (Loc, + Prefix => Request, + Selector_Name => Name_Target), + New_Occurrence_Of (Is_Local, Loc), + New_Occurrence_Of (Local_Address, Loc)))); + + -- For each subprogram, the receiving stub will be built and a case + -- statement will be made on the Subprogram_Id to dispatch to the + -- right subprogram. + + All_Calls_Remote_E := Boolean_Literals ( + Has_All_Calls_Remote (Defining_Entity (Pkg_Spec))); + + Overload_Counter_Table.Reset; + Reserve_NamingContext_Methods; + + Visit_Spec (Pkg_Spec); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Subp_Info_Array, + Constant_Present => True, + Aliased_Present => True, + Object_Definition => + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Occurrence_Of (RTE (RE_RCI_Subp_Info_Array), Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + New_List ( + Make_Range (Loc, + Low_Bound => + Make_Integer_Literal (Loc, + Intval => First_RCI_Subprogram_Id), + High_Bound => + Make_Integer_Literal (Loc, + Intval => + First_RCI_Subprogram_Id + + List_Length (Subp_Info_List) - 1))))))); + + if Present (First (Subp_Info_List)) then + Set_Expression (Last (Decls), + Make_Aggregate (Loc, + Component_Associations => Subp_Info_List)); + + -- Generate the dispatch statement to determine the subprogram id + -- of the called subprogram. + + -- We first test whether the reference that was used to make the + -- call was the base RCI reference (in which case Local_Address is + -- zero, and the method identifier from the request must be used + -- to determine which subprogram is called) or a reference + -- identifying one particular subprogram (in which case + -- Local_Address is the address of that subprogram, and the + -- method name from the request is ignored). The latter occurs + -- for the case of a call through a remote access-to-subprogram. + + -- In each case, cascaded elsifs are used to determine the proper + -- subprogram index. Using hash tables might be more efficient. + + Append_To (Pkg_RPC_Receiver_Statements, + Make_Implicit_If_Statement (Pkg_Spec, + Condition => + Make_Op_Ne (Loc, + Left_Opnd => New_Occurrence_Of (Local_Address, Loc), + Right_Opnd => New_Occurrence_Of + (RTE (RE_Null_Address), Loc)), + + Then_Statements => New_List ( + Make_Implicit_If_Statement (Pkg_Spec, + Condition => New_Occurrence_Of (Standard_False, Loc), + Then_Statements => New_List ( + Make_Null_Statement (Loc)), + Elsif_Parts => Dispatch_On_Address)), + + Else_Statements => New_List ( + Make_Implicit_If_Statement (Pkg_Spec, + Condition => New_Occurrence_Of (Standard_False, Loc), + Then_Statements => New_List (Make_Null_Statement (Loc)), + Elsif_Parts => Dispatch_On_Name)))); + + else + -- For a degenerate RCI with no visible subprograms, + -- Subp_Info_List has zero length, and the declaration is for an + -- empty array, in which case no initialization aggregate must be + -- generated. We do not generate a Dispatch_Statement either. + + -- No initialization provided: remove CONSTANT so that the + -- declaration is not an incomplete deferred constant. + + Set_Constant_Present (Last (Decls), False); + end if; + + -- Analyze Subp_Info_Array declaration + + Analyze (Last (Decls)); + + -- If we receive an invalid Subprogram_Id, it is best to do nothing + -- rather than raising an exception since we do not want someone + -- to crash a remote partition by sending invalid subprogram ids. + -- This is consistent with the other parts of the case statement + -- since even in presence of incorrect parameters in the stream, + -- every exception will be caught and (if the subprogram is not an + -- APC) put into the result stream and sent away. + + Append_To (Pkg_RPC_Receiver_Cases, + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => New_List (Make_Others_Choice (Loc)), + Statements => New_List (Make_Null_Statement (Loc)))); + + Append_To (Pkg_RPC_Receiver_Statements, + Make_Case_Statement (Loc, + Expression => New_Occurrence_Of (Subp_Index, Loc), + Alternatives => Pkg_RPC_Receiver_Cases)); + + -- Pkg_RPC_Receiver body is now complete: insert it into the tree and + -- analyze it. + + Append_To (Decls, Pkg_RPC_Receiver_Body); + Analyze (Last (Decls)); + + Pkg_RPC_Receiver_Object := + Make_Object_Declaration (Loc, + Defining_Identifier => Make_Temporary (Loc, 'R'), + Aliased_Present => True, + Object_Definition => New_Occurrence_Of (RTE (RE_Servant), Loc)); + Append_To (Decls, Pkg_RPC_Receiver_Object); + Analyze (Last (Decls)); + + Get_Library_Unit_Name_String (Pkg_Spec); + + -- Name + + Append_To (Register_Pkg_Actuals, + Make_String_Literal (Loc, + Strval => String_From_Name_Buffer)); + + -- Version + + Append_To (Register_Pkg_Actuals, + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of + (Defining_Entity (Pkg_Spec), Loc), + Attribute_Name => Name_Version)); + + -- Handler + + Append_To (Register_Pkg_Actuals, + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Pkg_RPC_Receiver, Loc), + Attribute_Name => Name_Access)); + + -- Receiver + + Append_To (Register_Pkg_Actuals, + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of ( + Defining_Identifier (Pkg_RPC_Receiver_Object), Loc), + Attribute_Name => Name_Access)); + + -- Subp_Info + + Append_To (Register_Pkg_Actuals, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Subp_Info_Array, Loc), + Attribute_Name => Name_Address)); + + -- Subp_Info_Len + + Append_To (Register_Pkg_Actuals, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Subp_Info_Array, Loc), + Attribute_Name => Name_Length)); + + -- Is_All_Calls_Remote + + Append_To (Register_Pkg_Actuals, + New_Occurrence_Of (All_Calls_Remote_E, Loc)); + + -- Finally call Register_Pkg_Receiving_Stub with the above parameters + + Append_To (Stmts, + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Register_Pkg_Receiving_Stub), Loc), + Parameter_Associations => Register_Pkg_Actuals)); + Analyze (Last (Stmts)); + end Add_Receiving_Stubs_To_Declarations; + + --------------------------------- + -- Build_General_Calling_Stubs -- + --------------------------------- + + procedure Build_General_Calling_Stubs + (Decls : List_Id; + Statements : List_Id; + Target_Object : Node_Id; + Subprogram_Id : Node_Id; + Asynchronous : Node_Id := Empty; + Is_Known_Asynchronous : Boolean := False; + Is_Known_Non_Asynchronous : Boolean := False; + Is_Function : Boolean; + Spec : Node_Id; + Stub_Type : Entity_Id := Empty; + RACW_Type : Entity_Id := Empty; + Nod : Node_Id) + is + Loc : constant Source_Ptr := Sloc (Nod); + + Request : constant Entity_Id := Make_Temporary (Loc, 'R'); + -- The request object constructed by these stubs + -- Could we use Name_R instead??? (see GLADE client stubs) + + function Make_Request_RTE_Call + (RE : RE_Id; + Actuals : List_Id := New_List) return Node_Id; + -- Generate a procedure call statement calling RE with the given + -- actuals. Request'Access is appended to the list. + + --------------------------- + -- Make_Request_RTE_Call -- + --------------------------- + + function Make_Request_RTE_Call + (RE : RE_Id; + Actuals : List_Id := New_List) return Node_Id + is + begin + Append_To (Actuals, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Request, Loc), + Attribute_Name => Name_Access)); + return Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE), Loc), + Parameter_Associations => Actuals); + end Make_Request_RTE_Call; + + Arguments : Node_Id; + -- Name of the named values list used to transmit parameters + -- to the remote package + + Result : Node_Id; + -- Name of the result named value (in non-APC cases) which get the + -- result of the remote subprogram. + + Result_TC : Node_Id; + -- Typecode expression for the result of the request (void + -- typecode for procedures). + + Exception_Return_Parameter : Node_Id; + -- Name of the parameter which will hold the exception sent by the + -- remote subprogram. + + Current_Parameter : Node_Id; + -- Current parameter being handled + + Ordered_Parameters_List : constant List_Id := + Build_Ordered_Parameters_List (Spec); + + Asynchronous_P : Node_Id; + -- A Boolean expression indicating whether this call is asynchronous + + Asynchronous_Statements : List_Id := No_List; + Non_Asynchronous_Statements : List_Id := No_List; + -- Statements specifics to the Asynchronous/Non-Asynchronous cases + + Extra_Formal_Statements : constant List_Id := New_List; + -- List of statements for extra formal parameters. It will appear + -- after the regular statements for writing out parameters. + + After_Statements : constant List_Id := New_List; + -- Statements to be executed after call returns (to assign IN OUT or + -- OUT parameter values). + + Etyp : Entity_Id; + -- The type of the formal parameter being processed + + Is_Controlling_Formal : Boolean; + Is_First_Controlling_Formal : Boolean; + First_Controlling_Formal_Seen : Boolean := False; + -- Controlling formal parameters of distributed object primitives + -- require special handling, and the first such parameter needs even + -- more special handling. + + begin + -- ??? document general form of stub subprograms for the PolyORB case + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Request, + Aliased_Present => True, + Object_Definition => + New_Occurrence_Of (RTE (RE_Request), Loc))); + + Result := Make_Temporary (Loc, 'R'); + + if Is_Function then + Result_TC := + PolyORB_Support.Helpers.Build_TypeCode_Call + (Loc, Etype (Result_Definition (Spec)), Decls); + else + Result_TC := New_Occurrence_Of (RTE (RE_TC_Void), Loc); + end if; + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Result, + Aliased_Present => False, + Object_Definition => + New_Occurrence_Of (RTE (RE_NamedValue), Loc), + Expression => + Make_Aggregate (Loc, + Component_Associations => New_List ( + Make_Component_Association (Loc, + Choices => New_List (Make_Identifier (Loc, Name_Name)), + Expression => + New_Occurrence_Of (RTE (RE_Result_Name), Loc)), + Make_Component_Association (Loc, + Choices => New_List ( + Make_Identifier (Loc, Name_Argument)), + Expression => + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (RE_Create_Any), Loc), + Parameter_Associations => New_List (Result_TC))), + Make_Component_Association (Loc, + Choices => New_List ( + Make_Identifier (Loc, Name_Arg_Modes)), + Expression => Make_Integer_Literal (Loc, 0)))))); + + if not Is_Known_Asynchronous then + Exception_Return_Parameter := Make_Temporary (Loc, 'E'); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Exception_Return_Parameter, + Object_Definition => + New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc))); + + else + Exception_Return_Parameter := Empty; + end if; + + -- Initialize and fill in arguments list + + Arguments := Make_Temporary (Loc, 'A'); + Declare_Create_NVList (Loc, Arguments, Decls, Statements); + + Current_Parameter := First (Ordered_Parameters_List); + while Present (Current_Parameter) loop + if Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type) then + Is_Controlling_Formal := True; + Is_First_Controlling_Formal := + not First_Controlling_Formal_Seen; + First_Controlling_Formal_Seen := True; + + else + Is_Controlling_Formal := False; + Is_First_Controlling_Formal := False; + end if; + + if Is_Controlling_Formal then + + -- For a controlling formal argument, we send its reference + + Etyp := RACW_Type; + + else + Etyp := Etype (Parameter_Type (Current_Parameter)); + end if; + + -- The first controlling formal parameter is treated specially: + -- it is used to set the target object of the call. + + if not Is_First_Controlling_Formal then + declare + Constrained : constant Boolean := + Is_Constrained (Etyp) + or else Is_Elementary_Type (Etyp); + + Any : constant Entity_Id := Make_Temporary (Loc, 'A'); + + Actual_Parameter : Node_Id := + New_Occurrence_Of ( + Defining_Identifier ( + Current_Parameter), Loc); + + Expr : Node_Id; + + begin + if Is_Controlling_Formal then + + -- For a controlling formal parameter (other than the + -- first one), use the corresponding RACW. If the + -- parameter is not an anonymous access parameter, that + -- involves taking its 'Unrestricted_Access. + + if Nkind (Parameter_Type (Current_Parameter)) + = N_Access_Definition + then + Actual_Parameter := OK_Convert_To + (Etyp, Actual_Parameter); + else + Actual_Parameter := OK_Convert_To (Etyp, + Make_Attribute_Reference (Loc, + Prefix => Actual_Parameter, + Attribute_Name => Name_Unrestricted_Access)); + end if; + + end if; + + if In_Present (Current_Parameter) + or else not Out_Present (Current_Parameter) + or else not Constrained + or else Is_Controlling_Formal + then + -- The parameter has an input value, is constrained at + -- runtime by an input value, or is a controlling formal + -- parameter (always passed as a reference) other than + -- the first one. + + Expr := PolyORB_Support.Helpers.Build_To_Any_Call + (Loc, Actual_Parameter, Decls); + + else + Expr := Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (RE_Create_Any), Loc), + Parameter_Associations => New_List ( + PolyORB_Support.Helpers.Build_TypeCode_Call + (Loc, Etyp, Decls))); + end if; + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Any, + Aliased_Present => False, + Object_Definition => + New_Occurrence_Of (RTE (RE_Any), Loc), + Expression => Expr)); + + Append_To (Statements, + Add_Parameter_To_NVList (Loc, + Parameter => Current_Parameter, + NVList => Arguments, + Constrained => Constrained, + Any => Any)); + + if Out_Present (Current_Parameter) + and then not Is_Controlling_Formal + then + if Is_Limited_Type (Etyp) then + Helpers.Assign_Opaque_From_Any (Loc, + Stms => After_Statements, + Typ => Etyp, + N => New_Occurrence_Of (Any, Loc), + Target => + Defining_Identifier (Current_Parameter)); + else + Append_To (After_Statements, + Make_Assignment_Statement (Loc, + Name => + New_Occurrence_Of ( + Defining_Identifier (Current_Parameter), Loc), + Expression => + PolyORB_Support.Helpers.Build_From_Any_Call + (Etyp, + New_Occurrence_Of (Any, Loc), + Decls))); + end if; + end if; + end; + end if; + + -- If the current parameter has a dynamic constrained status, then + -- this status is transmitted as well. + + -- This should be done for accessibility as well ??? + + if Nkind (Parameter_Type (Current_Parameter)) /= + N_Access_Definition + and then Need_Extra_Constrained (Current_Parameter) + then + -- In this block, we do not use the extra formal that has been + -- created because it does not exist at the time of expansion + -- when building calling stubs for remote access to subprogram + -- types. We create an extra variable of this type and push it + -- in the stream after the regular parameters. + + declare + Extra_Any_Parameter : constant Entity_Id := + Make_Temporary (Loc, 'P'); + + Parameter_Exp : constant Node_Id := + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of ( + Defining_Identifier (Current_Parameter), Loc), + Attribute_Name => Name_Constrained); + + begin + Set_Etype (Parameter_Exp, Etype (Standard_Boolean)); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Extra_Any_Parameter, + Aliased_Present => False, + Object_Definition => + New_Occurrence_Of (RTE (RE_Any), Loc), + Expression => + PolyORB_Support.Helpers.Build_To_Any_Call + (Loc, Parameter_Exp, Decls))); + + Append_To (Extra_Formal_Statements, + Add_Parameter_To_NVList (Loc, + Parameter => Extra_Any_Parameter, + NVList => Arguments, + Constrained => True, + Any => Extra_Any_Parameter)); + end; + end if; + + Next (Current_Parameter); + end loop; + + -- Append the formal statements list to the statements + + Append_List_To (Statements, Extra_Formal_Statements); + + Append_To (Statements, + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Request_Setup), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Request, Loc), + Target_Object, + Subprogram_Id, + New_Occurrence_Of (Arguments, Loc), + New_Occurrence_Of (Result, Loc), + New_Occurrence_Of (RTE (RE_Nil_Exc_List), Loc)))); + + pragma Assert + (not (Is_Known_Non_Asynchronous and Is_Known_Asynchronous)); + + if Is_Known_Non_Asynchronous or Is_Known_Asynchronous then + Asynchronous_P := + New_Occurrence_Of + (Boolean_Literals (Is_Known_Asynchronous), Loc); + + else + pragma Assert (Present (Asynchronous)); + Asynchronous_P := New_Copy_Tree (Asynchronous); + + -- The expression node Asynchronous will be used to build an 'if' + -- statement at the end of Build_General_Calling_Stubs: we need to + -- make a copy here. + end if; + + Append_To (Parameter_Associations (Last (Statements)), + Make_Indexed_Component (Loc, + Prefix => + New_Occurrence_Of ( + RTE (RE_Asynchronous_P_To_Sync_Scope), Loc), + Expressions => New_List (Asynchronous_P))); + + Append_To (Statements, Make_Request_RTE_Call (RE_Request_Invoke)); + + -- Asynchronous case + + if not Is_Known_Non_Asynchronous then + Asynchronous_Statements := New_List (Make_Null_Statement (Loc)); + end if; + + -- Non-asynchronous case + + if not Is_Known_Asynchronous then + -- Reraise an exception occurrence from the completed request. + -- If the exception occurrence is empty, this is a no-op. + + Non_Asynchronous_Statements := New_List ( + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Request_Raise_Occurrence), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Request, Loc)))); + + if Is_Function then + -- If this is a function call, read the value and return it + + Append_To (Non_Asynchronous_Statements, + Make_Tag_Check (Loc, + Make_Simple_Return_Statement (Loc, + PolyORB_Support.Helpers.Build_From_Any_Call + (Etype (Result_Definition (Spec)), + Make_Selected_Component (Loc, + Prefix => Result, + Selector_Name => Name_Argument), + Decls)))); + + else + + -- Case of a procedure: deal with IN OUT and OUT formals + + Append_List_To (Non_Asynchronous_Statements, After_Statements); + end if; + end if; + + if Is_Known_Asynchronous then + Append_List_To (Statements, Asynchronous_Statements); + + elsif Is_Known_Non_Asynchronous then + Append_List_To (Statements, Non_Asynchronous_Statements); + + else + pragma Assert (Present (Asynchronous)); + Append_To (Statements, + Make_Implicit_If_Statement (Nod, + Condition => Asynchronous, + Then_Statements => Asynchronous_Statements, + Else_Statements => Non_Asynchronous_Statements)); + end if; + end Build_General_Calling_Stubs; + + ----------------------- + -- Build_Stub_Target -- + ----------------------- + + function Build_Stub_Target + (Loc : Source_Ptr; + Decls : List_Id; + RCI_Locator : Entity_Id; + Controlling_Parameter : Entity_Id) return RPC_Target + is + Target_Info : RPC_Target (PCS_Kind => Name_PolyORB_DSA); + Target_Reference : constant Entity_Id := Make_Temporary (Loc, 'T'); + + begin + if Present (Controlling_Parameter) then + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Target_Reference, + + Object_Definition => + New_Occurrence_Of (RTE (RE_Object_Ref), Loc), + + Expression => + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (RTE (RE_Make_Ref), Loc), + Parameter_Associations => New_List ( + Make_Selected_Component (Loc, + Prefix => Controlling_Parameter, + Selector_Name => Name_Target))))); + + -- Note: Controlling_Parameter has the same components as + -- System.Partition_Interface.RACW_Stub_Type. + + Target_Info.Object := New_Occurrence_Of (Target_Reference, Loc); + + else + Target_Info.Object := + Make_Selected_Component (Loc, + Prefix => + Make_Identifier (Loc, Chars (RCI_Locator)), + Selector_Name => + Make_Identifier (Loc, Name_Get_RCI_Package_Ref)); + end if; + + return Target_Info; + end Build_Stub_Target; + + ----------------------------- + -- Build_RPC_Receiver_Body -- + ----------------------------- + + procedure Build_RPC_Receiver_Body + (RPC_Receiver : Entity_Id; + Request : out Entity_Id; + Subp_Id : out Entity_Id; + Subp_Index : out Entity_Id; + Stmts : out List_Id; + Decl : out Node_Id) + is + Loc : constant Source_Ptr := Sloc (RPC_Receiver); + + RPC_Receiver_Spec : Node_Id; + RPC_Receiver_Decls : List_Id; + + begin + Request := Make_Defining_Identifier (Loc, Name_R); + + RPC_Receiver_Spec := + Build_RPC_Receiver_Specification + (RPC_Receiver => RPC_Receiver, + Request_Parameter => Request); + + Subp_Id := Make_Defining_Identifier (Loc, Name_P); + Subp_Index := Make_Defining_Identifier (Loc, Name_I); + + RPC_Receiver_Decls := New_List ( + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Subp_Id, + Subtype_Mark => New_Occurrence_Of (Standard_String, Loc), + Name => + Make_Explicit_Dereference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => Request, + Selector_Name => Name_Operation))), + + Make_Object_Declaration (Loc, + Defining_Identifier => Subp_Index, + Object_Definition => + New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc), + Attribute_Name => Name_Last))); + + Stmts := New_List; + + Decl := + Make_Subprogram_Body (Loc, + Specification => RPC_Receiver_Spec, + Declarations => RPC_Receiver_Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stmts)); + end Build_RPC_Receiver_Body; + + -------------------------------------- + -- Build_Subprogram_Receiving_Stubs -- + -------------------------------------- + + function Build_Subprogram_Receiving_Stubs + (Vis_Decl : Node_Id; + Asynchronous : Boolean; + Dynamically_Asynchronous : Boolean := False; + Stub_Type : Entity_Id := Empty; + RACW_Type : Entity_Id := Empty; + Parent_Primitive : Entity_Id := Empty) return Node_Id + is + Loc : constant Source_Ptr := Sloc (Vis_Decl); + + Request_Parameter : constant Entity_Id := Make_Temporary (Loc, 'R'); + -- Formal parameter for receiving stubs: a descriptor for an incoming + -- request. + + Outer_Decls : constant List_Id := New_List; + -- At the outermost level, an NVList and Any's are declared for all + -- parameters. The Dynamic_Async flag also needs to be declared there + -- to be visible from the exception handling code. + + Outer_Statements : constant List_Id := New_List; + -- Statements that occur prior to the declaration of the actual + -- parameter variables. + + Outer_Extra_Formal_Statements : constant List_Id := New_List; + -- Statements concerning extra formal parameters, prior to the + -- declaration of the actual parameter variables. + + Decls : constant List_Id := New_List; + -- All the parameters will get declared before calling the real + -- subprograms. Also the out parameters will be declared. At this + -- level, parameters may be unconstrained. + + Statements : constant List_Id := New_List; + + After_Statements : constant List_Id := New_List; + -- Statements to be executed after the subprogram call + + Inner_Decls : List_Id := No_List; + -- In case of a function, the inner declarations are needed since + -- the result may be unconstrained. + + Excep_Handlers : List_Id := No_List; + + Parameter_List : constant List_Id := New_List; + -- List of parameters to be passed to the subprogram + + First_Controlling_Formal_Seen : Boolean := False; + + Current_Parameter : Node_Id; + + Ordered_Parameters_List : constant List_Id := + Build_Ordered_Parameters_List + (Specification (Vis_Decl)); + + Arguments : constant Entity_Id := Make_Temporary (Loc, 'A'); + -- Name of the named values list used to retrieve parameters + + Subp_Spec : Node_Id; + -- Subprogram specification + + Called_Subprogram : Node_Id; + -- The subprogram to call + + begin + if Present (RACW_Type) then + Called_Subprogram := + New_Occurrence_Of (Parent_Primitive, Loc); + else + Called_Subprogram := + New_Occurrence_Of + (Defining_Unit_Name (Specification (Vis_Decl)), Loc); + end if; + + Declare_Create_NVList (Loc, Arguments, Outer_Decls, Outer_Statements); + + -- Loop through every parameter and get its value from the stream. If + -- the parameter is unconstrained, then the parameter is read using + -- 'Input at the point of declaration. + + Current_Parameter := First (Ordered_Parameters_List); + while Present (Current_Parameter) loop + declare + Etyp : Entity_Id; + Constrained : Boolean; + Any : Entity_Id := Empty; + Object : constant Entity_Id := Make_Temporary (Loc, 'P'); + Expr : Node_Id := Empty; + + Is_Controlling_Formal : constant Boolean := + Is_RACW_Controlling_Formal + (Current_Parameter, Stub_Type); + + Is_First_Controlling_Formal : Boolean := False; + + Need_Extra_Constrained : Boolean; + -- True when an extra constrained actual is required + + begin + if Is_Controlling_Formal then + + -- Controlling formals in distributed object primitive + -- operations are handled specially: + + -- - the first controlling formal is used as the + -- target of the call; + + -- - the remaining controlling formals are transmitted + -- as RACWs. + + Etyp := RACW_Type; + Is_First_Controlling_Formal := + not First_Controlling_Formal_Seen; + First_Controlling_Formal_Seen := True; + + else + Etyp := Etype (Parameter_Type (Current_Parameter)); + end if; + + Constrained := + Is_Constrained (Etyp) or else Is_Elementary_Type (Etyp); + + if not Is_First_Controlling_Formal then + Any := Make_Temporary (Loc, 'A'); + + Append_To (Outer_Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Any, + Object_Definition => + New_Occurrence_Of (RTE (RE_Any), Loc), + Expression => + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (RE_Create_Any), Loc), + Parameter_Associations => New_List ( + PolyORB_Support.Helpers.Build_TypeCode_Call + (Loc, Etyp, Outer_Decls))))); + + Append_To (Outer_Statements, + Add_Parameter_To_NVList (Loc, + Parameter => Current_Parameter, + NVList => Arguments, + Constrained => Constrained, + Any => Any)); + end if; + + if Is_First_Controlling_Formal then + declare + Addr : constant Entity_Id := Make_Temporary (Loc, 'A'); + + Is_Local : constant Entity_Id := + Make_Temporary (Loc, 'L'); + + begin + -- Special case: obtain the first controlling formal + -- from the target of the remote call, instead of the + -- argument list. + + Append_To (Outer_Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Addr, + Object_Definition => + New_Occurrence_Of (RTE (RE_Address), Loc))); + + Append_To (Outer_Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Is_Local, + Object_Definition => + New_Occurrence_Of (Standard_Boolean, Loc))); + + Append_To (Outer_Statements, + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc), + Parameter_Associations => New_List ( + Make_Selected_Component (Loc, + Prefix => + New_Occurrence_Of ( + Request_Parameter, Loc), + Selector_Name => + Make_Identifier (Loc, Name_Target)), + New_Occurrence_Of (Is_Local, Loc), + New_Occurrence_Of (Addr, Loc)))); + + Expr := Unchecked_Convert_To (RACW_Type, + New_Occurrence_Of (Addr, Loc)); + end; + + elsif In_Present (Current_Parameter) + or else not Out_Present (Current_Parameter) + or else not Constrained + then + -- If an input parameter is constrained, then its reading is + -- deferred until the beginning of the subprogram body. If + -- it is unconstrained, then an expression is built for + -- the object declaration and the variable is set using + -- 'Input instead of 'Read. + + if Constrained and then Is_Limited_Type (Etyp) then + Helpers.Assign_Opaque_From_Any (Loc, + Stms => Statements, + Typ => Etyp, + N => New_Occurrence_Of (Any, Loc), + Target => Object); + + else + Expr := Helpers.Build_From_Any_Call + (Etyp, New_Occurrence_Of (Any, Loc), Decls); + + if Constrained then + Append_To (Statements, + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Object, Loc), + Expression => Expr)); + Expr := Empty; + + else + -- Expr will be used to initialize (and constrain) the + -- parameter when it is declared. + null; + end if; + + null; + end if; + end if; + + Need_Extra_Constrained := + Nkind (Parameter_Type (Current_Parameter)) /= + N_Access_Definition + and then + Ekind (Defining_Identifier (Current_Parameter)) /= E_Void + and then + Present (Extra_Constrained + (Defining_Identifier (Current_Parameter))); + + -- We may not associate an extra constrained actual to a + -- constant object, so if one is needed, declare the actual + -- as a variable even if it won't be modified. + + Build_Actual_Object_Declaration + (Object => Object, + Etyp => Etyp, + Variable => Need_Extra_Constrained + or else Out_Present (Current_Parameter), + Expr => Expr, + Decls => Decls); + Set_Etype (Object, Etyp); + + -- An out parameter may be written back using a 'Write + -- attribute instead of a 'Output because it has been + -- constrained by the parameter given to the caller. Note that + -- out controlling arguments in the case of a RACW are not put + -- back in the stream because the pointer on them has not + -- changed. + + if Out_Present (Current_Parameter) + and then not Is_Controlling_Formal + then + Append_To (After_Statements, + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (RTE (RE_Move_Any_Value), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Any, Loc), + PolyORB_Support.Helpers.Build_To_Any_Call + (Loc, New_Occurrence_Of (Object, Loc), Decls)))); + end if; + + -- For RACW controlling formals, the Etyp of Object is always + -- an RACW, even if the parameter is not of an anonymous access + -- type. In such case, we need to dereference it at call time. + + if Is_Controlling_Formal then + if Nkind (Parameter_Type (Current_Parameter)) /= + N_Access_Definition + then + Append_To (Parameter_List, + Make_Parameter_Association (Loc, + Selector_Name => + New_Occurrence_Of + (Defining_Identifier (Current_Parameter), Loc), + Explicit_Actual_Parameter => + Make_Explicit_Dereference (Loc, + Prefix => New_Occurrence_Of (Object, Loc)))); + + else + Append_To (Parameter_List, + Make_Parameter_Association (Loc, + Selector_Name => + New_Occurrence_Of + (Defining_Identifier (Current_Parameter), Loc), + + Explicit_Actual_Parameter => + New_Occurrence_Of (Object, Loc))); + end if; + + else + Append_To (Parameter_List, + Make_Parameter_Association (Loc, + Selector_Name => + New_Occurrence_Of ( + Defining_Identifier (Current_Parameter), Loc), + Explicit_Actual_Parameter => + New_Occurrence_Of (Object, Loc))); + end if; + + -- If the current parameter needs an extra formal, then read it + -- from the stream and set the corresponding semantic field in + -- the variable. If the kind of the parameter identifier is + -- E_Void, then this is a compiler generated parameter that + -- doesn't need an extra constrained status. + + -- The case of Extra_Accessibility should also be handled ??? + + if Need_Extra_Constrained then + declare + Extra_Parameter : constant Entity_Id := + Extra_Constrained + (Defining_Identifier + (Current_Parameter)); + + Extra_Any : constant Entity_Id := + Make_Temporary (Loc, 'A'); + + Formal_Entity : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => Chars (Extra_Parameter)); + + Formal_Type : constant Entity_Id := + Etype (Extra_Parameter); + + begin + Append_To (Outer_Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Extra_Any, + Object_Definition => + New_Occurrence_Of (RTE (RE_Any), Loc), + Expression => + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (RTE (RE_Create_Any), Loc), + Parameter_Associations => New_List ( + PolyORB_Support.Helpers.Build_TypeCode_Call + (Loc, Formal_Type, Outer_Decls))))); + + Append_To (Outer_Extra_Formal_Statements, + Add_Parameter_To_NVList (Loc, + Parameter => Extra_Parameter, + NVList => Arguments, + Constrained => True, + Any => Extra_Any)); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Formal_Entity, + Object_Definition => + New_Occurrence_Of (Formal_Type, Loc))); + + Append_To (Statements, + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Formal_Entity, Loc), + Expression => + PolyORB_Support.Helpers.Build_From_Any_Call + (Formal_Type, + New_Occurrence_Of (Extra_Any, Loc), + Decls))); + Set_Extra_Constrained (Object, Formal_Entity); + end; + end if; + end; + + Next (Current_Parameter); + end loop; + + -- Extra Formals should go after all the other parameters + + Append_List_To (Outer_Statements, Outer_Extra_Formal_Statements); + + Append_To (Outer_Statements, + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (RTE (RE_Request_Arguments), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Request_Parameter, Loc), + New_Occurrence_Of (Arguments, Loc)))); + + if Nkind (Specification (Vis_Decl)) = N_Function_Specification then + + -- The remote subprogram is a function: Build an inner block to be + -- able to hold a potentially unconstrained result in a variable. + + declare + Etyp : constant Entity_Id := + Etype (Result_Definition (Specification (Vis_Decl))); + Result : constant Node_Id := Make_Temporary (Loc, 'R'); + + begin + Inner_Decls := New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => Result, + Constant_Present => True, + Object_Definition => New_Occurrence_Of (Etyp, Loc), + Expression => + Make_Function_Call (Loc, + Name => Called_Subprogram, + Parameter_Associations => Parameter_List))); + + if Is_Class_Wide_Type (Etyp) then + + -- For a remote call to a function with a class-wide type, + -- check that the returned value satisfies the requirements + -- of (RM E.4(18)). + + Append_To (Inner_Decls, + Make_Transportable_Check (Loc, + New_Occurrence_Of (Result, Loc))); + + end if; + + Set_Etype (Result, Etyp); + Append_To (After_Statements, + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (RTE (RE_Set_Result), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Request_Parameter, Loc), + PolyORB_Support.Helpers.Build_To_Any_Call + (Loc, New_Occurrence_Of (Result, Loc), Decls)))); + + -- A DSA function does not have out or inout arguments + end; + + Append_To (Statements, + Make_Block_Statement (Loc, + Declarations => Inner_Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => After_Statements))); + + else + -- The remote subprogram is a procedure. We do not need any inner + -- block in this case. No specific processing is required here for + -- the dynamically asynchronous case: the indication of whether + -- call is asynchronous or not is managed by the Sync_Scope + -- attibute of the request, and is handled entirely in the + -- protocol layer. + + Append_To (After_Statements, + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (RTE (RE_Request_Set_Out), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Request_Parameter, Loc)))); + + Append_To (Statements, + Make_Procedure_Call_Statement (Loc, + Name => Called_Subprogram, + Parameter_Associations => Parameter_List)); + + Append_List_To (Statements, After_Statements); + end if; + + Subp_Spec := + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Make_Temporary (Loc, 'F'), + + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Request_Parameter, + Parameter_Type => + New_Occurrence_Of (RTE (RE_Request_Access), Loc)))); + + -- An exception raised during the execution of an incoming remote + -- subprogram call and that needs to be sent back to the caller is + -- propagated by the receiving stubs, and will be handled by the + -- caller (the distribution runtime). + + if Asynchronous and then not Dynamically_Asynchronous then + + -- For an asynchronous procedure, add a null exception handler + + Excep_Handlers := New_List ( + Make_Implicit_Exception_Handler (Loc, + Exception_Choices => New_List (Make_Others_Choice (Loc)), + Statements => New_List (Make_Null_Statement (Loc)))); + + else + -- In the other cases, if an exception is raised, then the + -- exception occurrence is propagated. + + null; + end if; + + Append_To (Outer_Statements, + Make_Block_Statement (Loc, + Declarations => Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Statements))); + + return + Make_Subprogram_Body (Loc, + Specification => Subp_Spec, + Declarations => Outer_Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Outer_Statements, + Exception_Handlers => Excep_Handlers)); + end Build_Subprogram_Receiving_Stubs; + + ------------- + -- Helpers -- + ------------- + + package body Helpers is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Find_Numeric_Representation + (Typ : Entity_Id) return Entity_Id; + -- Given a numeric type Typ, return the smallest integer or modular + -- type from Interfaces, or the smallest floating point type from + -- Standard whose range encompasses that of Typ. + + function Make_Helper_Function_Name + (Loc : Source_Ptr; + Typ : Entity_Id; + Nam : Name_Id) return Entity_Id; + -- Return the name to be assigned for helper subprogram Nam of Typ + + ------------------------------------------------------------ + -- Common subprograms for building various tree fragments -- + ------------------------------------------------------------ + + function Build_Get_Aggregate_Element + (Loc : Source_Ptr; + Any : Entity_Id; + TC : Node_Id; + Idx : Node_Id) return Node_Id; + -- Build a call to Get_Aggregate_Element on Any for typecode TC, + -- returning the Idx'th element. + + generic + Subprogram : Entity_Id; + -- Reference location for constructed nodes + + Arry : Entity_Id; + -- For 'Range and Etype + + Indexes : List_Id; + -- For the construction of the innermost element expression + + with procedure Add_Process_Element + (Stmts : List_Id; + Any : Entity_Id; + Counter : Entity_Id; + Datum : Node_Id); + + procedure Append_Array_Traversal + (Stmts : List_Id; + Any : Entity_Id; + Counter : Entity_Id := Empty; + Depth : Pos := 1); + -- Build nested loop statements that iterate over the elements of an + -- array Arry. The statement(s) built by Add_Process_Element are + -- executed for each element; Indexes is the list of indexes to be + -- used in the construction of the indexed component that denotes the + -- current element. Subprogram is the entity for the subprogram for + -- which this iterator is generated. The generated statements are + -- appended to Stmts. + + generic + Rec : Entity_Id; + -- The record entity being dealt with + + with procedure Add_Process_Element + (Stmts : List_Id; + Container : Node_Or_Entity_Id; + Counter : in out Int; + Rec : Entity_Id; + Field : Node_Id); + -- Rec is the instance of the record type, or Empty. + -- Field is either the N_Defining_Identifier for a component, + -- or an N_Variant_Part. + + procedure Append_Record_Traversal + (Stmts : List_Id; + Clist : Node_Id; + Container : Node_Or_Entity_Id; + Counter : in out Int); + -- Process component list Clist. Individual fields are passed + -- to Field_Processing. Each variant part is also processed. + -- Container is the outer Any (for From_Any/To_Any), + -- the outer typecode (for TC) to which the operation applies. + + ----------------------------- + -- Append_Record_Traversal -- + ----------------------------- + + procedure Append_Record_Traversal + (Stmts : List_Id; + Clist : Node_Id; + Container : Node_Or_Entity_Id; + Counter : in out Int) + is + CI : List_Id; + VP : Node_Id; + -- Clist's Component_Items and Variant_Part + + Item : Node_Id; + Def : Entity_Id; + + begin + if No (Clist) then + return; + end if; + + CI := Component_Items (Clist); + VP := Variant_Part (Clist); + + Item := First (CI); + while Present (Item) loop + Def := Defining_Identifier (Item); + + if not Is_Internal_Name (Chars (Def)) then + Add_Process_Element + (Stmts, Container, Counter, Rec, Def); + end if; + + Next (Item); + end loop; + + if Present (VP) then + Add_Process_Element (Stmts, Container, Counter, Rec, VP); + end if; + end Append_Record_Traversal; + + ----------------------------- + -- Assign_Opaque_From_Any -- + ----------------------------- + + procedure Assign_Opaque_From_Any + (Loc : Source_Ptr; + Stms : List_Id; + Typ : Entity_Id; + N : Node_Id; + Target : Entity_Id) + is + Strm : constant Entity_Id := Make_Temporary (Loc, 'S'); + Expr : Node_Id; + + Read_Call_List : List_Id; + -- List on which to place the 'Read attribute reference + + begin + -- Strm : Buffer_Stream_Type; + + Append_To (Stms, + Make_Object_Declaration (Loc, + Defining_Identifier => Strm, + Aliased_Present => True, + Object_Definition => + New_Occurrence_Of (RTE (RE_Buffer_Stream_Type), Loc))); + + -- Any_To_BS (Strm, A); + + Append_To (Stms, + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (RTE (RE_Any_To_BS), Loc), + Parameter_Associations => New_List ( + N, + New_Occurrence_Of (Strm, Loc)))); + + if Transmit_As_Unconstrained (Typ) then + Expr := + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Typ, Loc), + Attribute_Name => Name_Input, + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Strm, Loc), + Attribute_Name => Name_Access))); + + -- Target := Typ'Input (Strm'Access) + + if Present (Target) then + Append_To (Stms, + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Target, Loc), + Expression => Expr)); + + -- return Typ'Input (Strm'Access); + + else + Append_To (Stms, + Make_Simple_Return_Statement (Loc, + Expression => Expr)); + end if; + + else + if Present (Target) then + Read_Call_List := Stms; + Expr := New_Occurrence_Of (Target, Loc); + + else + declare + Temp : constant Entity_Id := Make_Temporary (Loc, 'R'); + + begin + Read_Call_List := New_List; + Expr := New_Occurrence_Of (Temp, Loc); + + Append_To (Stms, Make_Block_Statement (Loc, + Declarations => New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => + Temp, + Object_Definition => + New_Occurrence_Of (Typ, Loc))), + + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Read_Call_List))); + end; + end if; + + -- Typ'Read (Strm'Access, [Target|Temp]) + + Append_To (Read_Call_List, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Typ, Loc), + Attribute_Name => Name_Read, + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Strm, Loc), + Attribute_Name => Name_Access), + Expr))); + + if No (Target) then + + -- return Temp + + Append_To (Read_Call_List, + Make_Simple_Return_Statement (Loc, + Expression => New_Copy (Expr))); + end if; + end if; + end Assign_Opaque_From_Any; + + ------------------------- + -- Build_From_Any_Call -- + ------------------------- + + function Build_From_Any_Call + (Typ : Entity_Id; + N : Node_Id; + Decls : List_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (N); + + U_Type : Entity_Id := Underlying_Type (Typ); + + Fnam : Entity_Id := Empty; + Lib_RE : RE_Id := RE_Null; + Result : Node_Id; + + begin + -- First simple case where the From_Any function is present + -- in the type's TSS. + + Fnam := Find_Inherited_TSS (U_Type, TSS_From_Any); + + -- For the subtype representing a generic actual type, go to the + -- actual type. + + if Is_Generic_Actual_Type (U_Type) then + U_Type := Underlying_Type (Base_Type (U_Type)); + end if; + + -- For a standard subtype, go to the base type + + if Sloc (U_Type) <= Standard_Location then + U_Type := Base_Type (U_Type); + + -- For a user subtype, go to first subtype + + elsif Comes_From_Source (U_Type) + and then Nkind (Declaration_Node (U_Type)) + = N_Subtype_Declaration + then + U_Type := First_Subtype (U_Type); + end if; + + -- Check first for Boolean and Character. These are enumeration + -- types, but we treat them specially, since they may require + -- special handling in the transfer protocol. However, this + -- special handling only applies if they have standard + -- representation, otherwise they are treated like any other + -- enumeration type. + + if Present (Fnam) then + null; + + elsif U_Type = Standard_Boolean then + Lib_RE := RE_FA_B; + + elsif U_Type = Standard_Character then + Lib_RE := RE_FA_C; + + elsif U_Type = Standard_Wide_Character then + Lib_RE := RE_FA_WC; + + elsif U_Type = Standard_Wide_Wide_Character then + Lib_RE := RE_FA_WWC; + + -- Floating point types + + elsif U_Type = Standard_Short_Float then + Lib_RE := RE_FA_SF; + + elsif U_Type = Standard_Float then + Lib_RE := RE_FA_F; + + elsif U_Type = Standard_Long_Float then + Lib_RE := RE_FA_LF; + + elsif U_Type = Standard_Long_Long_Float then + Lib_RE := RE_FA_LLF; + + -- Integer types + + elsif U_Type = RTE (RE_Integer_8) then + Lib_RE := RE_FA_I8; + + elsif U_Type = RTE (RE_Integer_16) then + Lib_RE := RE_FA_I16; + + elsif U_Type = RTE (RE_Integer_32) then + Lib_RE := RE_FA_I32; + + elsif U_Type = RTE (RE_Integer_64) then + Lib_RE := RE_FA_I64; + + -- Unsigned integer types + + elsif U_Type = RTE (RE_Unsigned_8) then + Lib_RE := RE_FA_U8; + + elsif U_Type = RTE (RE_Unsigned_16) then + Lib_RE := RE_FA_U16; + + elsif U_Type = RTE (RE_Unsigned_32) then + Lib_RE := RE_FA_U32; + + elsif U_Type = RTE (RE_Unsigned_64) then + Lib_RE := RE_FA_U64; + + elsif Is_RTE (U_Type, RE_Unbounded_String) then + Lib_RE := RE_FA_String; + + -- Special DSA types + + elsif Is_RTE (U_Type, RE_Any_Container_Ptr) then + Lib_RE := RE_FA_A; + + -- Other (non-primitive) types + + else + declare + Decl : Entity_Id; + + begin + Build_From_Any_Function (Loc, U_Type, Decl, Fnam); + Append_To (Decls, Decl); + end; + end if; + + -- Call the function + + if Lib_RE /= RE_Null then + pragma Assert (No (Fnam)); + Fnam := RTE (Lib_RE); + end if; + + Result := + Make_Function_Call (Loc, + Name => New_Occurrence_Of (Fnam, Loc), + Parameter_Associations => New_List (N)); + + -- We must set the type of Result, so the unchecked conversion + -- from the underlying type to the base type is properly done. + + Set_Etype (Result, U_Type); + + return Unchecked_Convert_To (Typ, Result); + end Build_From_Any_Call; + + ----------------------------- + -- Build_From_Any_Function -- + ----------------------------- + + procedure Build_From_Any_Function + (Loc : Source_Ptr; + Typ : Entity_Id; + Decl : out Node_Id; + Fnam : out Entity_Id) + is + Spec : Node_Id; + Decls : constant List_Id := New_List; + Stms : constant List_Id := New_List; + + Any_Parameter : constant Entity_Id := Make_Temporary (Loc, 'A'); + + Use_Opaque_Representation : Boolean; + + begin + -- For a derived type, we can't go past the base type (to the + -- parent type) here, because that would cause the attribute's + -- formal parameter to have the wrong type; hence the Base_Type + -- check here. + + if Is_Itype (Typ) and then Typ /= Base_Type (Typ) then + Build_From_Any_Function + (Loc => Loc, + Typ => Etype (Typ), + Decl => Decl, + Fnam => Fnam); + return; + end if; + + Fnam := Make_Helper_Function_Name (Loc, Typ, Name_From_Any); + + Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => Fnam, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Any_Parameter, + Parameter_Type => New_Occurrence_Of (RTE (RE_Any), Loc))), + Result_Definition => New_Occurrence_Of (Typ, Loc)); + + -- The RACW case is taken care of by Exp_Dist.Add_RACW_From_Any + + pragma Assert + (not (Is_Remote_Access_To_Class_Wide_Type (Typ))); + + Use_Opaque_Representation := False; + + if Has_Stream_Attribute_Definition + (Typ, TSS_Stream_Output, At_Any_Place => True) + or else + Has_Stream_Attribute_Definition + (Typ, TSS_Stream_Write, At_Any_Place => True) + then + -- If user-defined stream attributes are specified for this + -- type, use them and transmit data as an opaque sequence of + -- stream elements. + + Use_Opaque_Representation := True; + + elsif Is_Derived_Type (Typ) and then not Is_Tagged_Type (Typ) then + Append_To (Stms, + Make_Simple_Return_Statement (Loc, + Expression => + OK_Convert_To (Typ, + Build_From_Any_Call + (Root_Type (Typ), + New_Occurrence_Of (Any_Parameter, Loc), + Decls)))); + + elsif Is_Record_Type (Typ) + and then not Is_Derived_Type (Typ) + and then not Is_Tagged_Type (Typ) + then + if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then + Append_To (Stms, + Make_Simple_Return_Statement (Loc, + Expression => + Build_From_Any_Call + (Etype (Typ), + New_Occurrence_Of (Any_Parameter, Loc), + Decls))); + + else + declare + Disc : Entity_Id := Empty; + Discriminant_Associations : List_Id; + Rdef : constant Node_Id := + Type_Definition + (Declaration_Node (Typ)); + Component_Counter : Int := 0; + + -- The returned object + + Res : constant Entity_Id := Make_Temporary (Loc, 'R'); + + Res_Definition : Node_Id := New_Occurrence_Of (Typ, Loc); + + procedure FA_Rec_Add_Process_Element + (Stmts : List_Id; + Any : Entity_Id; + Counter : in out Int; + Rec : Entity_Id; + Field : Node_Id); + + procedure FA_Append_Record_Traversal is + new Append_Record_Traversal + (Rec => Res, + Add_Process_Element => FA_Rec_Add_Process_Element); + + -------------------------------- + -- FA_Rec_Add_Process_Element -- + -------------------------------- + + procedure FA_Rec_Add_Process_Element + (Stmts : List_Id; + Any : Entity_Id; + Counter : in out Int; + Rec : Entity_Id; + Field : Node_Id) + is + Ctyp : Entity_Id; + begin + if Nkind (Field) = N_Defining_Identifier then + -- A regular component + + Ctyp := Etype (Field); + + Append_To (Stmts, + Make_Assignment_Statement (Loc, + Name => Make_Selected_Component (Loc, + Prefix => + New_Occurrence_Of (Rec, Loc), + Selector_Name => + New_Occurrence_Of (Field, Loc)), + + Expression => + Build_From_Any_Call (Ctyp, + Build_Get_Aggregate_Element (Loc, + Any => Any, + TC => + Build_TypeCode_Call (Loc, Ctyp, Decls), + Idx => + Make_Integer_Literal (Loc, Counter)), + Decls))); + + else + -- A variant part + + declare + Variant : Node_Id; + Struct_Counter : Int := 0; + + Block_Decls : constant List_Id := New_List; + Block_Stmts : constant List_Id := New_List; + VP_Stmts : List_Id; + + Alt_List : constant List_Id := New_List; + Choice_List : List_Id; + + Struct_Any : constant Entity_Id := + Make_Temporary (Loc, 'S'); + + begin + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Struct_Any, + Constant_Present => True, + Object_Definition => + New_Occurrence_Of (RTE (RE_Any), Loc), + Expression => + Make_Function_Call (Loc, + Name => + New_Occurrence_Of + (RTE (RE_Extract_Union_Value), Loc), + + Parameter_Associations => New_List ( + Build_Get_Aggregate_Element (Loc, + Any => Any, + TC => + Make_Function_Call (Loc, + Name => New_Occurrence_Of ( + RTE (RE_Any_Member_Type), Loc), + Parameter_Associations => + New_List ( + New_Occurrence_Of (Any, Loc), + Make_Integer_Literal (Loc, + Intval => Counter))), + Idx => + Make_Integer_Literal (Loc, + Intval => Counter)))))); + + Append_To (Stmts, + Make_Block_Statement (Loc, + Declarations => Block_Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Block_Stmts))); + + Append_To (Block_Stmts, + Make_Case_Statement (Loc, + Expression => + Make_Selected_Component (Loc, + Prefix => Rec, + Selector_Name => Chars (Name (Field))), + Alternatives => Alt_List)); + + Variant := First_Non_Pragma (Variants (Field)); + while Present (Variant) loop + Choice_List := + New_Copy_List_Tree + (Discrete_Choices (Variant)); + + VP_Stmts := New_List; + + -- Struct_Counter should be reset before + -- handling a variant part. Indeed only one + -- of the case statement alternatives will be + -- executed at run time, so the counter must + -- start at 0 for every case statement. + + Struct_Counter := 0; + + FA_Append_Record_Traversal ( + Stmts => VP_Stmts, + Clist => Component_List (Variant), + Container => Struct_Any, + Counter => Struct_Counter); + + Append_To (Alt_List, + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => Choice_List, + Statements => VP_Stmts)); + Next_Non_Pragma (Variant); + end loop; + end; + end if; + + Counter := Counter + 1; + end FA_Rec_Add_Process_Element; + + begin + -- First all discriminants + + if Has_Discriminants (Typ) then + Discriminant_Associations := New_List; + + Disc := First_Discriminant (Typ); + while Present (Disc) loop + declare + Disc_Var_Name : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => Chars (Disc)); + Disc_Type : constant Entity_Id := + Etype (Disc); + + begin + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Disc_Var_Name, + Constant_Present => True, + Object_Definition => + New_Occurrence_Of (Disc_Type, Loc), + + Expression => + Build_From_Any_Call (Disc_Type, + Build_Get_Aggregate_Element (Loc, + Any => Any_Parameter, + TC => Build_TypeCode_Call + (Loc, Disc_Type, Decls), + Idx => Make_Integer_Literal (Loc, + Intval => Component_Counter)), + Decls))); + + Component_Counter := Component_Counter + 1; + + Append_To (Discriminant_Associations, + Make_Discriminant_Association (Loc, + Selector_Names => New_List ( + New_Occurrence_Of (Disc, Loc)), + Expression => + New_Occurrence_Of (Disc_Var_Name, Loc))); + end; + Next_Discriminant (Disc); + end loop; + + Res_Definition := + Make_Subtype_Indication (Loc, + Subtype_Mark => Res_Definition, + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Discriminant_Associations)); + end if; + + -- Now we have all the discriminants in variables, we can + -- declared a constrained object. Note that we are not + -- initializing (non-discriminant) components directly in + -- the object declarations, because which fields to + -- initialize depends (at run time) on the discriminant + -- values. + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Res, + Object_Definition => Res_Definition)); + + -- ... then all components + + FA_Append_Record_Traversal (Stms, + Clist => Component_List (Rdef), + Container => Any_Parameter, + Counter => Component_Counter); + + Append_To (Stms, + Make_Simple_Return_Statement (Loc, + Expression => New_Occurrence_Of (Res, Loc))); + end; + end if; + + elsif Is_Array_Type (Typ) then + declare + Constrained : constant Boolean := Is_Constrained (Typ); + + procedure FA_Ary_Add_Process_Element + (Stmts : List_Id; + Any : Entity_Id; + Counter : Entity_Id; + Datum : Node_Id); + -- Assign the current element (as identified by Counter) of + -- Any to the variable denoted by name Datum, and advance + -- Counter by 1. If Datum is not an Any, a call to From_Any + -- for its type is inserted. + + -------------------------------- + -- FA_Ary_Add_Process_Element -- + -------------------------------- + + procedure FA_Ary_Add_Process_Element + (Stmts : List_Id; + Any : Entity_Id; + Counter : Entity_Id; + Datum : Node_Id) + is + Assignment : constant Node_Id := + Make_Assignment_Statement (Loc, + Name => Datum, + Expression => Empty); + + Element_Any : Node_Id; + + begin + declare + Element_TC : Node_Id; + + begin + if Etype (Datum) = RTE (RE_Any) then + + -- When Datum is an Any the Etype field is not + -- sufficient to determine the typecode of Datum + -- (which can be a TC_SEQUENCE or TC_ARRAY + -- depending on the value of Constrained). + + -- Therefore we retrieve the typecode which has + -- been constructed in Append_Array_Traversal with + -- a call to Get_Any_Type. + + Element_TC := + Make_Function_Call (Loc, + Name => New_Occurrence_Of ( + RTE (RE_Get_Any_Type), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Entity (Datum), Loc))); + else + -- For non Any Datum we simply construct a typecode + -- matching the Etype of the Datum. + + Element_TC := Build_TypeCode_Call + (Loc, Etype (Datum), Decls); + end if; + + Element_Any := + Build_Get_Aggregate_Element (Loc, + Any => Any, + TC => Element_TC, + Idx => New_Occurrence_Of (Counter, Loc)); + end; + + -- Note: here we *prepend* statements to Stmts, so + -- we must do it in reverse order. + + Prepend_To (Stmts, + Make_Assignment_Statement (Loc, + Name => + New_Occurrence_Of (Counter, Loc), + Expression => + Make_Op_Add (Loc, + Left_Opnd => New_Occurrence_Of (Counter, Loc), + Right_Opnd => Make_Integer_Literal (Loc, 1)))); + + if Nkind (Datum) /= N_Attribute_Reference then + + -- We ignore the value of the length of each + -- dimension, since the target array has already been + -- constrained anyway. + + if Etype (Datum) /= RTE (RE_Any) then + Set_Expression (Assignment, + Build_From_Any_Call + (Component_Type (Typ), Element_Any, Decls)); + else + Set_Expression (Assignment, Element_Any); + end if; + + Prepend_To (Stmts, Assignment); + end if; + end FA_Ary_Add_Process_Element; + + ------------------------ + -- Local Declarations -- + ------------------------ + + Counter : constant Entity_Id := + Make_Defining_Identifier (Loc, Name_J); + + Initial_Counter_Value : Int := 0; + + Component_TC : constant Entity_Id := + Make_Defining_Identifier (Loc, Name_T); + + Res : constant Entity_Id := + Make_Defining_Identifier (Loc, Name_R); + + procedure Append_From_Any_Array_Iterator is + new Append_Array_Traversal ( + Subprogram => Fnam, + Arry => Res, + Indexes => New_List, + Add_Process_Element => FA_Ary_Add_Process_Element); + + Res_Subtype_Indication : Node_Id := + New_Occurrence_Of (Typ, Loc); + + begin + if not Constrained then + declare + Ndim : constant Int := Number_Dimensions (Typ); + Lnam : Name_Id; + Hnam : Name_Id; + Indx : Node_Id := First_Index (Typ); + Indt : Entity_Id; + + Ranges : constant List_Id := New_List; + + begin + for J in 1 .. Ndim loop + Lnam := New_External_Name ('L', J); + Hnam := New_External_Name ('H', J); + + -- Note, for empty arrays bounds may be out of + -- the range of Etype (Indx). + + Indt := Base_Type (Etype (Indx)); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Lnam), + Constant_Present => True, + Object_Definition => + New_Occurrence_Of (Indt, Loc), + Expression => + Build_From_Any_Call + (Indt, + Build_Get_Aggregate_Element (Loc, + Any => Any_Parameter, + TC => Build_TypeCode_Call + (Loc, Indt, Decls), + Idx => + Make_Integer_Literal (Loc, J - 1)), + Decls))); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Hnam), + + Constant_Present => True, + + Object_Definition => + New_Occurrence_Of (Indt, Loc), + + Expression => Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Indt, Loc), + + Attribute_Name => Name_Val, + + Expressions => New_List ( + Make_Op_Subtract (Loc, + Left_Opnd => + Make_Op_Add (Loc, + Left_Opnd => + OK_Convert_To + (Standard_Long_Integer, + Make_Identifier (Loc, Lnam)), + + Right_Opnd => + OK_Convert_To + (Standard_Long_Integer, + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (RTE ( + RE_Get_Nested_Sequence_Length + ), Loc), + Parameter_Associations => + New_List ( + New_Occurrence_Of ( + Any_Parameter, Loc), + Make_Integer_Literal (Loc, + Intval => J))))), + + Right_Opnd => + Make_Integer_Literal (Loc, 1)))))); + + Append_To (Ranges, + Make_Range (Loc, + Low_Bound => Make_Identifier (Loc, Lnam), + High_Bound => Make_Identifier (Loc, Hnam))); + + Next_Index (Indx); + end loop; + + -- Now we have all the necessary bound information: + -- apply the set of range constraints to the + -- (unconstrained) nominal subtype of Res. + + Initial_Counter_Value := Ndim; + Res_Subtype_Indication := Make_Subtype_Indication (Loc, + Subtype_Mark => Res_Subtype_Indication, + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => Ranges)); + end; + end if; + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Res, + Object_Definition => Res_Subtype_Indication)); + Set_Etype (Res, Typ); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Counter, + Object_Definition => + New_Occurrence_Of (RTE (RE_Unsigned_32), Loc), + Expression => + Make_Integer_Literal (Loc, Initial_Counter_Value))); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Component_TC, + Constant_Present => True, + Object_Definition => + New_Occurrence_Of (RTE (RE_TypeCode), Loc), + Expression => + Build_TypeCode_Call (Loc, + Component_Type (Typ), Decls))); + + Append_From_Any_Array_Iterator + (Stms, Any_Parameter, Counter); + + Append_To (Stms, + Make_Simple_Return_Statement (Loc, + Expression => New_Occurrence_Of (Res, Loc))); + end; + + elsif Is_Integer_Type (Typ) or else Is_Unsigned_Type (Typ) then + Append_To (Stms, + Make_Simple_Return_Statement (Loc, + Expression => + Unchecked_Convert_To (Typ, + Build_From_Any_Call + (Find_Numeric_Representation (Typ), + New_Occurrence_Of (Any_Parameter, Loc), + Decls)))); + + else + Use_Opaque_Representation := True; + end if; + + if Use_Opaque_Representation then + Assign_Opaque_From_Any (Loc, + Stms => Stms, + Typ => Typ, + N => New_Occurrence_Of (Any_Parameter, Loc), + Target => Empty); + end if; + + Decl := + Make_Subprogram_Body (Loc, + Specification => Spec, + Declarations => Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stms)); + end Build_From_Any_Function; + + --------------------------------- + -- Build_Get_Aggregate_Element -- + --------------------------------- + + function Build_Get_Aggregate_Element + (Loc : Source_Ptr; + Any : Entity_Id; + TC : Node_Id; + Idx : Node_Id) return Node_Id + is + begin + return Make_Function_Call (Loc, + Name => + New_Occurrence_Of (RTE (RE_Get_Aggregate_Element), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Any, Loc), + TC, + Idx)); + end Build_Get_Aggregate_Element; + + ------------------------- + -- Build_Reposiroty_Id -- + ------------------------- + + procedure Build_Name_And_Repository_Id + (E : Entity_Id; + Name_Str : out String_Id; + Repo_Id_Str : out String_Id) + is + begin + Start_String; + Store_String_Chars ("DSA:"); + Get_Library_Unit_Name_String (Scope (E)); + Store_String_Chars + (Name_Buffer (Name_Buffer'First .. + Name_Buffer'First + Name_Len - 1)); + Store_String_Char ('.'); + Get_Name_String (Chars (E)); + Store_String_Chars + (Name_Buffer (Name_Buffer'First .. + Name_Buffer'First + Name_Len - 1)); + Store_String_Chars (":1.0"); + Repo_Id_Str := End_String; + Name_Str := String_From_Name_Buffer; + end Build_Name_And_Repository_Id; + + ----------------------- + -- Build_To_Any_Call -- + ----------------------- + + function Build_To_Any_Call + (Loc : Source_Ptr; + N : Node_Id; + Decls : List_Id) return Node_Id + is + Typ : Entity_Id := Etype (N); + U_Type : Entity_Id; + C_Type : Entity_Id; + Fnam : Entity_Id := Empty; + Lib_RE : RE_Id := RE_Null; + + begin + -- If N is a selected component, then maybe its Etype has not been + -- set yet: try to use Etype of the selector_name in that case. + + if No (Typ) and then Nkind (N) = N_Selected_Component then + Typ := Etype (Selector_Name (N)); + end if; + + pragma Assert (Present (Typ)); + + -- Get full view for private type, completion for incomplete type + + U_Type := Underlying_Type (Typ); + + -- First simple case where the To_Any function is present in the + -- type's TSS. + + Fnam := Find_Inherited_TSS (U_Type, TSS_To_Any); + + -- For the subtype representing a generic actual type, go to the + -- actual type. + + if Is_Generic_Actual_Type (U_Type) then + U_Type := Underlying_Type (Base_Type (U_Type)); + end if; + + -- For a standard subtype, go to the base type + + if Sloc (U_Type) <= Standard_Location then + U_Type := Base_Type (U_Type); + + -- For a user subtype, go to first subtype + + elsif Comes_From_Source (U_Type) + and then Nkind (Declaration_Node (U_Type)) + = N_Subtype_Declaration + then + U_Type := First_Subtype (U_Type); + end if; + + if Present (Fnam) then + null; + + -- Check first for Boolean and Character. These are enumeration + -- types, but we treat them specially, since they may require + -- special handling in the transfer protocol. However, this + -- special handling only applies if they have standard + -- representation, otherwise they are treated like any other + -- enumeration type. + + elsif U_Type = Standard_Boolean then + Lib_RE := RE_TA_B; + + elsif U_Type = Standard_Character then + Lib_RE := RE_TA_C; + + elsif U_Type = Standard_Wide_Character then + Lib_RE := RE_TA_WC; + + elsif U_Type = Standard_Wide_Wide_Character then + Lib_RE := RE_TA_WWC; + + -- Floating point types + + elsif U_Type = Standard_Short_Float then + Lib_RE := RE_TA_SF; + + elsif U_Type = Standard_Float then + Lib_RE := RE_TA_F; + + elsif U_Type = Standard_Long_Float then + Lib_RE := RE_TA_LF; + + elsif U_Type = Standard_Long_Long_Float then + Lib_RE := RE_TA_LLF; + + -- Integer types + + elsif U_Type = RTE (RE_Integer_8) then + Lib_RE := RE_TA_I8; + + elsif U_Type = RTE (RE_Integer_16) then + Lib_RE := RE_TA_I16; + + elsif U_Type = RTE (RE_Integer_32) then + Lib_RE := RE_TA_I32; + + elsif U_Type = RTE (RE_Integer_64) then + Lib_RE := RE_TA_I64; + + -- Unsigned integer types + + elsif U_Type = RTE (RE_Unsigned_8) then + Lib_RE := RE_TA_U8; + + elsif U_Type = RTE (RE_Unsigned_16) then + Lib_RE := RE_TA_U16; + + elsif U_Type = RTE (RE_Unsigned_32) then + Lib_RE := RE_TA_U32; + + elsif U_Type = RTE (RE_Unsigned_64) then + Lib_RE := RE_TA_U64; + + elsif Is_RTE (U_Type, RE_Unbounded_String) then + Lib_RE := RE_TA_String; + + -- Special DSA types + + elsif Is_RTE (U_Type, RE_Any_Container_Ptr) then + Lib_RE := RE_TA_A; + U_Type := Typ; + + elsif U_Type = Underlying_Type (RTE (RE_TypeCode)) then + + -- No corresponding FA_TC ??? + + Lib_RE := RE_TA_TC; + + -- Other (non-primitive) types + + else + declare + Decl : Entity_Id; + begin + Build_To_Any_Function (Loc, U_Type, Decl, Fnam); + Append_To (Decls, Decl); + end; + end if; + + -- Call the function + + if Lib_RE /= RE_Null then + pragma Assert (No (Fnam)); + Fnam := RTE (Lib_RE); + end if; + + -- If Fnam is already analyzed, find the proper expected type, + -- else we have a newly constructed To_Any function and we know + -- that the expected type of its parameter is U_Type. + + if Ekind (Fnam) = E_Function + and then Present (First_Formal (Fnam)) + then + C_Type := Etype (First_Formal (Fnam)); + else + C_Type := U_Type; + end if; + + return + Make_Function_Call (Loc, + Name => New_Occurrence_Of (Fnam, Loc), + Parameter_Associations => + New_List (OK_Convert_To (C_Type, N))); + end Build_To_Any_Call; + + --------------------------- + -- Build_To_Any_Function -- + --------------------------- + + procedure Build_To_Any_Function + (Loc : Source_Ptr; + Typ : Entity_Id; + Decl : out Node_Id; + Fnam : out Entity_Id) + is + Spec : Node_Id; + Decls : constant List_Id := New_List; + Stms : constant List_Id := New_List; + + Expr_Parameter : Entity_Id; + Any : Entity_Id; + Result_TC : Node_Id; + + Any_Decl : Node_Id; + + Use_Opaque_Representation : Boolean; + -- When True, use stream attributes and represent type as an + -- opaque sequence of bytes. + + begin + -- For a derived type, we can't go past the base type (to the + -- parent type) here, because that would cause the attribute's + -- formal parameter to have the wrong type; hence the Base_Type + -- check here. + + if Is_Itype (Typ) and then Typ /= Base_Type (Typ) then + Build_To_Any_Function + (Loc => Loc, + Typ => Etype (Typ), + Decl => Decl, + Fnam => Fnam); + return; + end if; + + Expr_Parameter := Make_Defining_Identifier (Loc, Name_E); + Any := Make_Defining_Identifier (Loc, Name_A); + Result_TC := Build_TypeCode_Call (Loc, Typ, Decls); + + Fnam := Make_Helper_Function_Name (Loc, Typ, Name_To_Any); + + Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => Fnam, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Expr_Parameter, + Parameter_Type => New_Occurrence_Of (Typ, Loc))), + Result_Definition => New_Occurrence_Of (RTE (RE_Any), Loc)); + Set_Etype (Expr_Parameter, Typ); + + Any_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Any, + Object_Definition => New_Occurrence_Of (RTE (RE_Any), Loc)); + + Use_Opaque_Representation := False; + + if Has_Stream_Attribute_Definition + (Typ, TSS_Stream_Output, At_Any_Place => True) + or else + Has_Stream_Attribute_Definition + (Typ, TSS_Stream_Write, At_Any_Place => True) + then + -- If user-defined stream attributes are specified for this + -- type, use them and transmit data as an opaque sequence of + -- stream elements. + + Use_Opaque_Representation := True; + + elsif Is_Derived_Type (Typ) and then not Is_Tagged_Type (Typ) then + + -- Non-tagged derived type: convert to root type + + declare + Rt_Type : constant Entity_Id := Root_Type (Typ); + Expr : constant Node_Id := + OK_Convert_To + (Rt_Type, + New_Occurrence_Of (Expr_Parameter, Loc)); + begin + Set_Expression (Any_Decl, + Build_To_Any_Call (Loc, Expr, Decls)); + end; + + elsif Is_Record_Type (Typ) and then not Is_Tagged_Type (Typ) then + + -- Non-tagged record type + + if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then + declare + Rt_Type : constant Entity_Id := Etype (Typ); + Expr : constant Node_Id := + OK_Convert_To (Rt_Type, + New_Occurrence_Of (Expr_Parameter, Loc)); + + begin + Set_Expression + (Any_Decl, Build_To_Any_Call (Loc, Expr, Decls)); + end; + + -- Comment needed here (and label on declare block ???) + + else + declare + Disc : Entity_Id := Empty; + Rdef : constant Node_Id := + Type_Definition (Declaration_Node (Typ)); + Counter : Int := 0; + Elements : constant List_Id := New_List; + + procedure TA_Rec_Add_Process_Element + (Stmts : List_Id; + Container : Node_Or_Entity_Id; + Counter : in out Int; + Rec : Entity_Id; + Field : Node_Id); + -- Processing routine for traversal below + + procedure TA_Append_Record_Traversal is + new Append_Record_Traversal + (Rec => Expr_Parameter, + Add_Process_Element => TA_Rec_Add_Process_Element); + + -------------------------------- + -- TA_Rec_Add_Process_Element -- + -------------------------------- + + procedure TA_Rec_Add_Process_Element + (Stmts : List_Id; + Container : Node_Or_Entity_Id; + Counter : in out Int; + Rec : Entity_Id; + Field : Node_Id) + is + Field_Ref : Node_Id; + + begin + if Nkind (Field) = N_Defining_Identifier then + + -- A regular component + + Field_Ref := Make_Selected_Component (Loc, + Prefix => New_Occurrence_Of (Rec, Loc), + Selector_Name => New_Occurrence_Of (Field, Loc)); + Set_Etype (Field_Ref, Etype (Field)); + + Append_To (Stmts, + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of ( + RTE (RE_Add_Aggregate_Element), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Container, Loc), + Build_To_Any_Call (Loc, Field_Ref, Decls)))); + + else + -- A variant part + + Variant_Part : declare + Variant : Node_Id; + Struct_Counter : Int := 0; + + Block_Decls : constant List_Id := New_List; + Block_Stmts : constant List_Id := New_List; + VP_Stmts : List_Id; + + Alt_List : constant List_Id := New_List; + Choice_List : List_Id; + + Union_Any : constant Entity_Id := + Make_Temporary (Loc, 'V'); + + Struct_Any : constant Entity_Id := + Make_Temporary (Loc, 'S'); + + function Make_Discriminant_Reference + return Node_Id; + -- Build reference to the discriminant for this + -- variant part. + + --------------------------------- + -- Make_Discriminant_Reference -- + --------------------------------- + + function Make_Discriminant_Reference + return Node_Id + is + Nod : constant Node_Id := + Make_Selected_Component (Loc, + Prefix => Rec, + Selector_Name => + Chars (Name (Field))); + begin + Set_Etype (Nod, Etype (Name (Field))); + return Nod; + end Make_Discriminant_Reference; + + -- Start of processing for Variant_Part + + begin + Append_To (Stmts, + Make_Block_Statement (Loc, + Declarations => + Block_Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Block_Stmts))); + + -- Declare variant part aggregate (Union_Any). + -- Knowing the position of this VP in the + -- variant record, we can fetch the VP typecode + -- from Container. + + Append_To (Block_Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Union_Any, + Object_Definition => + New_Occurrence_Of (RTE (RE_Any), Loc), + Expression => + Make_Function_Call (Loc, + Name => New_Occurrence_Of ( + RTE (RE_Create_Any), Loc), + Parameter_Associations => New_List ( + Make_Function_Call (Loc, + Name => + New_Occurrence_Of ( + RTE (RE_Any_Member_Type), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Container, Loc), + Make_Integer_Literal (Loc, + Counter))))))); + + -- Declare inner struct aggregate (which + -- contains the components of this VP). + + Append_To (Block_Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Struct_Any, + Object_Definition => + New_Occurrence_Of (RTE (RE_Any), Loc), + Expression => + Make_Function_Call (Loc, + Name => New_Occurrence_Of ( + RTE (RE_Create_Any), Loc), + Parameter_Associations => New_List ( + Make_Function_Call (Loc, + Name => + New_Occurrence_Of ( + RTE (RE_Any_Member_Type), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Union_Any, Loc), + Make_Integer_Literal (Loc, + Uint_1))))))); + + -- Build case statement + + Append_To (Block_Stmts, + Make_Case_Statement (Loc, + Expression => Make_Discriminant_Reference, + Alternatives => Alt_List)); + + Variant := First_Non_Pragma (Variants (Field)); + while Present (Variant) loop + Choice_List := New_Copy_List_Tree + (Discrete_Choices (Variant)); + + VP_Stmts := New_List; + + -- Append discriminant val to union aggregate + + Append_To (VP_Stmts, + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of ( + RTE (RE_Add_Aggregate_Element), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Union_Any, Loc), + Build_To_Any_Call + (Loc, + Make_Discriminant_Reference, + Block_Decls)))); + + -- Populate inner struct aggregate + + -- Struct_Counter should be reset before + -- handling a variant part. Indeed only one + -- of the case statement alternatives will be + -- executed at run time, so the counter must + -- start at 0 for every case statement. + + Struct_Counter := 0; + + TA_Append_Record_Traversal + (Stmts => VP_Stmts, + Clist => Component_List (Variant), + Container => Struct_Any, + Counter => Struct_Counter); + + -- Append inner struct to union aggregate + + Append_To (VP_Stmts, + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of + (RTE (RE_Add_Aggregate_Element), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Union_Any, Loc), + New_Occurrence_Of (Struct_Any, Loc)))); + + -- Append union to outer aggregate + + Append_To (VP_Stmts, + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of + (RTE (RE_Add_Aggregate_Element), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Container, Loc), + New_Occurrence_Of + (Union_Any, Loc)))); + + Append_To (Alt_List, + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => Choice_List, + Statements => VP_Stmts)); + + Next_Non_Pragma (Variant); + end loop; + end Variant_Part; + end if; + + Counter := Counter + 1; + end TA_Rec_Add_Process_Element; + + begin + -- Records are encoded in a TC_STRUCT aggregate: + + -- -- Outer aggregate (TC_STRUCT) + -- | [discriminant1] + -- | [discriminant2] + -- | ... + -- | + -- | [component1] + -- | [component2] + -- | ... + + -- A component can be a common component or variant part + + -- A variant part is encoded as a TC_UNION aggregate: + + -- -- Variant Part Aggregate (TC_UNION) + -- | [discriminant choice for this Variant Part] + -- | + -- | -- Inner struct (TC_STRUCT) + -- | | [component1] + -- | | [component2] + -- | | ... + + -- Let's start by building the outer aggregate. First we + -- construct Elements array containing all discriminants. + + if Has_Discriminants (Typ) then + Disc := First_Discriminant (Typ); + while Present (Disc) loop + declare + Discriminant : constant Entity_Id := + Make_Selected_Component (Loc, + Prefix => + Expr_Parameter, + Selector_Name => + Chars (Disc)); + + begin + Set_Etype (Discriminant, Etype (Disc)); + + Append_To (Elements, + Make_Component_Association (Loc, + Choices => New_List ( + Make_Integer_Literal (Loc, Counter)), + Expression => + Build_To_Any_Call (Loc, + Discriminant, Decls))); + end; + + Counter := Counter + 1; + Next_Discriminant (Disc); + end loop; + + else + -- If there are no discriminants, we declare an empty + -- Elements array. + + declare + Dummy_Any : constant Entity_Id := + Make_Temporary (Loc, 'A'); + + begin + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Dummy_Any, + Object_Definition => + New_Occurrence_Of (RTE (RE_Any), Loc))); + + Append_To (Elements, + Make_Component_Association (Loc, + Choices => New_List ( + Make_Range (Loc, + Low_Bound => + Make_Integer_Literal (Loc, 1), + High_Bound => + Make_Integer_Literal (Loc, 0))), + Expression => + New_Occurrence_Of (Dummy_Any, Loc))); + end; + end if; + + -- We build the result aggregate with discriminants + -- as the first elements. + + Set_Expression (Any_Decl, + Make_Function_Call (Loc, + Name => New_Occurrence_Of + (RTE (RE_Any_Aggregate_Build), Loc), + Parameter_Associations => New_List ( + Result_TC, + Make_Aggregate (Loc, + Component_Associations => Elements)))); + Result_TC := Empty; + + -- Then we append all the components to the result + -- aggregate. + + TA_Append_Record_Traversal (Stms, + Clist => Component_List (Rdef), + Container => Any, + Counter => Counter); + end; + end if; + + elsif Is_Array_Type (Typ) then + + -- Constrained and unconstrained array types + + declare + Constrained : constant Boolean := Is_Constrained (Typ); + + procedure TA_Ary_Add_Process_Element + (Stmts : List_Id; + Any : Entity_Id; + Counter : Entity_Id; + Datum : Node_Id); + + -------------------------------- + -- TA_Ary_Add_Process_Element -- + -------------------------------- + + procedure TA_Ary_Add_Process_Element + (Stmts : List_Id; + Any : Entity_Id; + Counter : Entity_Id; + Datum : Node_Id) + is + pragma Unreferenced (Counter); + + Element_Any : Node_Id; + + begin + if Etype (Datum) = RTE (RE_Any) then + Element_Any := Datum; + else + Element_Any := Build_To_Any_Call (Loc, Datum, Decls); + end if; + + Append_To (Stmts, + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of ( + RTE (RE_Add_Aggregate_Element), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Any, Loc), + Element_Any))); + end TA_Ary_Add_Process_Element; + + procedure Append_To_Any_Array_Iterator is + new Append_Array_Traversal ( + Subprogram => Fnam, + Arry => Expr_Parameter, + Indexes => New_List, + Add_Process_Element => TA_Ary_Add_Process_Element); + + Index : Node_Id; + + begin + Set_Expression (Any_Decl, + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (RTE (RE_Create_Any), Loc), + Parameter_Associations => New_List (Result_TC))); + Result_TC := Empty; + + if not Constrained then + Index := First_Index (Typ); + for J in 1 .. Number_Dimensions (Typ) loop + Append_To (Stms, + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of ( + RTE (RE_Add_Aggregate_Element), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Any, Loc), + Build_To_Any_Call (Loc, + OK_Convert_To (Etype (Index), + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Expr_Parameter, Loc), + Attribute_Name => Name_First, + Expressions => New_List ( + Make_Integer_Literal (Loc, J)))), + Decls)))); + Next_Index (Index); + end loop; + end if; + + Append_To_Any_Array_Iterator (Stms, Any); + end; + + elsif Is_Integer_Type (Typ) or else Is_Unsigned_Type (Typ) then + + -- Integer types + + Set_Expression (Any_Decl, + Build_To_Any_Call (Loc, + OK_Convert_To ( + Find_Numeric_Representation (Typ), + New_Occurrence_Of (Expr_Parameter, Loc)), + Decls)); + + else + -- Default case, including tagged types: opaque representation + + Use_Opaque_Representation := True; + end if; + + if Use_Opaque_Representation then + declare + Strm : constant Entity_Id := Make_Temporary (Loc, 'S'); + -- Stream used to store data representation produced by + -- stream attribute. + + begin + -- Generate: + -- Strm : aliased Buffer_Stream_Type; + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => + Strm, + Aliased_Present => + True, + Object_Definition => + New_Occurrence_Of (RTE (RE_Buffer_Stream_Type), Loc))); + + -- Generate: + -- T'Output (Strm'Access, E); + + Append_To (Stms, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Typ, Loc), + Attribute_Name => Name_Output, + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Strm, Loc), + Attribute_Name => Name_Access), + New_Occurrence_Of (Expr_Parameter, Loc)))); + + -- Generate: + -- BS_To_Any (Strm, A); + + Append_To (Stms, + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (RTE (RE_BS_To_Any), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Strm, Loc), + New_Occurrence_Of (Any, Loc)))); + + -- Generate: + -- Release_Buffer (Strm); + + Append_To (Stms, + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (RTE (RE_Release_Buffer), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Strm, Loc)))); + end; + end if; + + Append_To (Decls, Any_Decl); + + if Present (Result_TC) then + Append_To (Stms, + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (RTE (RE_Set_TC), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Any, Loc), + Result_TC))); + end if; + + Append_To (Stms, + Make_Simple_Return_Statement (Loc, + Expression => New_Occurrence_Of (Any, Loc))); + + Decl := + Make_Subprogram_Body (Loc, + Specification => Spec, + Declarations => Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stms)); + end Build_To_Any_Function; + + ------------------------- + -- Build_TypeCode_Call -- + ------------------------- + + function Build_TypeCode_Call + (Loc : Source_Ptr; + Typ : Entity_Id; + Decls : List_Id) return Node_Id + is + U_Type : Entity_Id := Underlying_Type (Typ); + -- The full view, if Typ is private; the completion, + -- if Typ is incomplete. + + Fnam : Entity_Id := Empty; + Lib_RE : RE_Id := RE_Null; + Expr : Node_Id; + + begin + -- Special case System.PolyORB.Interface.Any: its primitives have + -- not been set yet, so can't call Find_Inherited_TSS. + + if Typ = RTE (RE_Any) then + Fnam := RTE (RE_TC_A); + + else + -- First simple case where the TypeCode is present + -- in the type's TSS. + + Fnam := Find_Inherited_TSS (U_Type, TSS_TypeCode); + end if; + + -- For the subtype representing a generic actual type, go to the + -- actual type. + + if Is_Generic_Actual_Type (U_Type) then + U_Type := Underlying_Type (Base_Type (U_Type)); + end if; + + -- For a standard subtype, go to the base type + + if Sloc (U_Type) <= Standard_Location then + U_Type := Base_Type (U_Type); + + -- For a user subtype, go to first subtype + + elsif Comes_From_Source (U_Type) + and then Nkind (Declaration_Node (U_Type)) + = N_Subtype_Declaration + then + U_Type := First_Subtype (U_Type); + end if; + + if No (Fnam) then + if U_Type = Standard_Boolean then + Lib_RE := RE_TC_B; + + elsif U_Type = Standard_Character then + Lib_RE := RE_TC_C; + + elsif U_Type = Standard_Wide_Character then + Lib_RE := RE_TC_WC; + + elsif U_Type = Standard_Wide_Wide_Character then + Lib_RE := RE_TC_WWC; + + -- Floating point types + + elsif U_Type = Standard_Short_Float then + Lib_RE := RE_TC_SF; + + elsif U_Type = Standard_Float then + Lib_RE := RE_TC_F; + + elsif U_Type = Standard_Long_Float then + Lib_RE := RE_TC_LF; + + elsif U_Type = Standard_Long_Long_Float then + Lib_RE := RE_TC_LLF; + + -- Integer types (walk back to the base type) + + elsif U_Type = RTE (RE_Integer_8) then + Lib_RE := RE_TC_I8; + + elsif U_Type = RTE (RE_Integer_16) then + Lib_RE := RE_TC_I16; + + elsif U_Type = RTE (RE_Integer_32) then + Lib_RE := RE_TC_I32; + + elsif U_Type = RTE (RE_Integer_64) then + Lib_RE := RE_TC_I64; + + -- Unsigned integer types + + elsif U_Type = RTE (RE_Unsigned_8) then + Lib_RE := RE_TC_U8; + + elsif U_Type = RTE (RE_Unsigned_16) then + Lib_RE := RE_TC_U16; + + elsif U_Type = RTE (RE_Unsigned_32) then + Lib_RE := RE_TC_U32; + + elsif U_Type = RTE (RE_Unsigned_64) then + Lib_RE := RE_TC_U64; + + elsif Is_RTE (U_Type, RE_Unbounded_String) then + Lib_RE := RE_TC_String; + + -- Special DSA types + + elsif Is_RTE (U_Type, RE_Any_Container_Ptr) then + Lib_RE := RE_TC_A; + + -- Other (non-primitive) types + + else + declare + Decl : Entity_Id; + begin + Build_TypeCode_Function (Loc, U_Type, Decl, Fnam); + Append_To (Decls, Decl); + end; + end if; + + if Lib_RE /= RE_Null then + Fnam := RTE (Lib_RE); + end if; + end if; + + -- Call the function + + Expr := + Make_Function_Call (Loc, Name => New_Occurrence_Of (Fnam, Loc)); + + -- Allow Expr to be used as arg to Build_To_Any_Call immediately + + Set_Etype (Expr, RTE (RE_TypeCode)); + + return Expr; + end Build_TypeCode_Call; + + ----------------------------- + -- Build_TypeCode_Function -- + ----------------------------- + + procedure Build_TypeCode_Function + (Loc : Source_Ptr; + Typ : Entity_Id; + Decl : out Node_Id; + Fnam : out Entity_Id) + is + Spec : Node_Id; + Decls : constant List_Id := New_List; + Stms : constant List_Id := New_List; + + TCNam : constant Entity_Id := + Make_Helper_Function_Name (Loc, Typ, Name_TypeCode); + + Parameters : List_Id; + + procedure Add_String_Parameter + (S : String_Id; + Parameter_List : List_Id); + -- Add a literal for S to Parameters + + procedure Add_TypeCode_Parameter + (TC_Node : Node_Id; + Parameter_List : List_Id); + -- Add the typecode for Typ to Parameters + + procedure Add_Long_Parameter + (Expr_Node : Node_Id; + Parameter_List : List_Id); + -- Add a signed long integer expression to Parameters + + procedure Initialize_Parameter_List + (Name_String : String_Id; + Repo_Id_String : String_Id; + Parameter_List : out List_Id); + -- Return a list that contains the first two parameters + -- for a parameterized typecode: name and repository id. + + function Make_Constructed_TypeCode + (Kind : Entity_Id; + Parameters : List_Id) return Node_Id; + -- Call TC_Build with the given kind and parameters + + procedure Return_Constructed_TypeCode (Kind : Entity_Id); + -- Make a return statement that calls TC_Build with the given + -- typecode kind, and the constructed parameters list. + + procedure Return_Alias_TypeCode (Base_TypeCode : Node_Id); + -- Return a typecode that is a TC_Alias for the given typecode + + -------------------------- + -- Add_String_Parameter -- + -------------------------- + + procedure Add_String_Parameter + (S : String_Id; + Parameter_List : List_Id) + is + begin + Append_To (Parameter_List, + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (RE_TA_Std_String), Loc), + Parameter_Associations => New_List ( + Make_String_Literal (Loc, S)))); + end Add_String_Parameter; + + ---------------------------- + -- Add_TypeCode_Parameter -- + ---------------------------- + + procedure Add_TypeCode_Parameter + (TC_Node : Node_Id; + Parameter_List : List_Id) + is + begin + Append_To (Parameter_List, + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (RE_TA_TC), Loc), + Parameter_Associations => New_List (TC_Node))); + end Add_TypeCode_Parameter; + + ------------------------ + -- Add_Long_Parameter -- + ------------------------ + + procedure Add_Long_Parameter + (Expr_Node : Node_Id; + Parameter_List : List_Id) + is + begin + Append_To (Parameter_List, + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (RTE (RE_TA_I32), Loc), + Parameter_Associations => New_List (Expr_Node))); + end Add_Long_Parameter; + + ------------------------------- + -- Initialize_Parameter_List -- + ------------------------------- + + procedure Initialize_Parameter_List + (Name_String : String_Id; + Repo_Id_String : String_Id; + Parameter_List : out List_Id) + is + begin + Parameter_List := New_List; + Add_String_Parameter (Name_String, Parameter_List); + Add_String_Parameter (Repo_Id_String, Parameter_List); + end Initialize_Parameter_List; + + --------------------------- + -- Return_Alias_TypeCode -- + --------------------------- + + procedure Return_Alias_TypeCode (Base_TypeCode : Node_Id) is + begin + Add_TypeCode_Parameter (Base_TypeCode, Parameters); + Return_Constructed_TypeCode (RTE (RE_TC_Alias)); + end Return_Alias_TypeCode; + + ------------------------------- + -- Make_Constructed_TypeCode -- + ------------------------------- + + function Make_Constructed_TypeCode + (Kind : Entity_Id; + Parameters : List_Id) return Node_Id + is + Constructed_TC : constant Node_Id := + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (RTE (RE_TC_Build), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Kind, Loc), + Make_Aggregate (Loc, + Expressions => Parameters))); + begin + Set_Etype (Constructed_TC, RTE (RE_TypeCode)); + return Constructed_TC; + end Make_Constructed_TypeCode; + + --------------------------------- + -- Return_Constructed_TypeCode -- + --------------------------------- + + procedure Return_Constructed_TypeCode (Kind : Entity_Id) is + begin + Append_To (Stms, + Make_Simple_Return_Statement (Loc, + Expression => + Make_Constructed_TypeCode (Kind, Parameters))); + end Return_Constructed_TypeCode; + + ------------------ + -- Record types -- + ------------------ + + procedure TC_Rec_Add_Process_Element + (Params : List_Id; + Any : Entity_Id; + Counter : in out Int; + Rec : Entity_Id; + Field : Node_Id); + + procedure TC_Append_Record_Traversal is + new Append_Record_Traversal ( + Rec => Empty, + Add_Process_Element => TC_Rec_Add_Process_Element); + + -------------------------------- + -- TC_Rec_Add_Process_Element -- + -------------------------------- + + procedure TC_Rec_Add_Process_Element + (Params : List_Id; + Any : Entity_Id; + Counter : in out Int; + Rec : Entity_Id; + Field : Node_Id) + is + pragma Unreferenced (Any, Counter, Rec); + + begin + if Nkind (Field) = N_Defining_Identifier then + + -- A regular component + + Add_TypeCode_Parameter + (Build_TypeCode_Call (Loc, Etype (Field), Decls), Params); + Get_Name_String (Chars (Field)); + Add_String_Parameter (String_From_Name_Buffer, Params); + + else + + -- A variant part + + Variant_Part : declare + Disc_Type : constant Entity_Id := Etype (Name (Field)); + + Is_Enum : constant Boolean := + Is_Enumeration_Type (Disc_Type); + + Union_TC_Params : List_Id; + + U_Name : constant Name_Id := + New_External_Name (Chars (Typ), 'V', -1); + + Name_Str : String_Id; + Struct_TC_Params : List_Id; + + Variant : Node_Id; + Choice : Node_Id; + Default : constant Node_Id := + Make_Integer_Literal (Loc, -1); + + Dummy_Counter : Int := 0; + + Choice_Index : Int := 0; + -- Index of current choice in TypeCode, used to identify + -- it as the default choice if it is a "when others". + + procedure Add_Params_For_Variant_Components; + -- Add a struct TypeCode and a corresponding member name + -- to the union parameter list. + + -- Ordering of declarations is a complete mess in this + -- area, it is supposed to be types/variables, then + -- subprogram specs, then subprogram bodies ??? + + --------------------------------------- + -- Add_Params_For_Variant_Components -- + --------------------------------------- + + procedure Add_Params_For_Variant_Components is + S_Name : constant Name_Id := + New_External_Name (U_Name, 'S', -1); + + begin + Get_Name_String (S_Name); + Name_Str := String_From_Name_Buffer; + Initialize_Parameter_List + (Name_Str, Name_Str, Struct_TC_Params); + + -- Build struct parameters + + TC_Append_Record_Traversal (Struct_TC_Params, + Component_List (Variant), + Empty, + Dummy_Counter); + + Add_TypeCode_Parameter + (Make_Constructed_TypeCode + (RTE (RE_TC_Struct), Struct_TC_Params), + Union_TC_Params); + + Add_String_Parameter (Name_Str, Union_TC_Params); + end Add_Params_For_Variant_Components; + + -- Start of processing for Variant_Part + + begin + Get_Name_String (U_Name); + Name_Str := String_From_Name_Buffer; + + Initialize_Parameter_List + (Name_Str, Name_Str, Union_TC_Params); + + -- Add union in enclosing parameter list + + Add_TypeCode_Parameter + (Make_Constructed_TypeCode + (RTE (RE_TC_Union), Union_TC_Params), + Params); + + Add_String_Parameter (Name_Str, Params); + + -- Build union parameters + + Add_TypeCode_Parameter + (Build_TypeCode_Call (Loc, Disc_Type, Decls), + Union_TC_Params); + + Add_Long_Parameter (Default, Union_TC_Params); + + Variant := First_Non_Pragma (Variants (Field)); + while Present (Variant) loop + Choice := First (Discrete_Choices (Variant)); + while Present (Choice) loop + case Nkind (Choice) is + when N_Range => + declare + L : constant Uint := + Expr_Value (Low_Bound (Choice)); + H : constant Uint := + Expr_Value (High_Bound (Choice)); + J : Uint := L; + -- 3.8.1(8) guarantees that the bounds of + -- this range are static. + + Expr : Node_Id; + + begin + while J <= H loop + if Is_Enum then + Expr := Get_Enum_Lit_From_Pos + (Disc_Type, J, Loc); + else + Expr := + Make_Integer_Literal (Loc, J); + end if; + + Set_Etype (Expr, Disc_Type); + Append_To (Union_TC_Params, + Build_To_Any_Call (Loc, Expr, Decls)); + + Add_Params_For_Variant_Components; + J := J + Uint_1; + end loop; + + Choice_Index := + Choice_Index + UI_To_Int (H - L) + 1; + end; + + when N_Others_Choice => + + -- This variant has a default choice. We must + -- therefore set the default parameter to the + -- current choice index. This parameter is by + -- construction the 4th in Union_TC_Params. + + Replace + (Pick (Union_TC_Params, 4), + Make_Function_Call (Loc, + Name => + New_Occurrence_Of + (RTE (RE_TA_I32), Loc), + Parameter_Associations => + New_List ( + Make_Integer_Literal (Loc, + Intval => Choice_Index)))); + + -- Add a placeholder member label for the + -- default case, which must have the + -- discriminant type. + + declare + Exp : constant Node_Id := + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of + (Disc_Type, Loc), + Attribute_Name => Name_First); + begin + Set_Etype (Exp, Disc_Type); + Append_To (Union_TC_Params, + Build_To_Any_Call (Loc, Exp, Decls)); + end; + + Add_Params_For_Variant_Components; + Choice_Index := Choice_Index + 1; + + -- Case of an explicit choice + + when others => + declare + Exp : constant Node_Id := + New_Copy_Tree (Choice); + begin + Append_To (Union_TC_Params, + Build_To_Any_Call (Loc, Exp, Decls)); + end; + + Add_Params_For_Variant_Components; + Choice_Index := Choice_Index + 1; + end case; + + Next (Choice); + end loop; + + Next_Non_Pragma (Variant); + end loop; + end Variant_Part; + end if; + end TC_Rec_Add_Process_Element; + + Type_Name_Str : String_Id; + Type_Repo_Id_Str : String_Id; + + -- Start of processing for Build_TypeCode_Function + + begin + -- For a derived type, we can't go past the base type (to the + -- parent type) here, because that would cause the attribute's + -- formal parameter to have the wrong type; hence the Base_Type + -- check here. + + if Is_Itype (Typ) and then Typ /= Base_Type (Typ) then + Build_TypeCode_Function + (Loc => Loc, + Typ => Etype (Typ), + Decl => Decl, + Fnam => Fnam); + return; + end if; + + Fnam := TCNam; + + Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => Fnam, + Parameter_Specifications => Empty_List, + Result_Definition => + New_Occurrence_Of (RTE (RE_TypeCode), Loc)); + + Build_Name_And_Repository_Id (Typ, + Name_Str => Type_Name_Str, Repo_Id_Str => Type_Repo_Id_Str); + + Initialize_Parameter_List + (Type_Name_Str, Type_Repo_Id_Str, Parameters); + + if Has_Stream_Attribute_Definition + (Typ, TSS_Stream_Output, At_Any_Place => True) + or else + Has_Stream_Attribute_Definition + (Typ, TSS_Stream_Write, At_Any_Place => True) + then + -- If user-defined stream attributes are specified for this + -- type, use them and transmit data as an opaque sequence of + -- stream elements. + + Return_Alias_TypeCode + (New_Occurrence_Of (RTE (RE_TC_Opaque), Loc)); + + elsif Is_Derived_Type (Typ) and then not Is_Tagged_Type (Typ) then + Return_Alias_TypeCode ( + Build_TypeCode_Call (Loc, Etype (Typ), Decls)); + + elsif Is_Integer_Type (Typ) or else Is_Unsigned_Type (Typ) then + Return_Alias_TypeCode ( + Build_TypeCode_Call (Loc, + Find_Numeric_Representation (Typ), Decls)); + + elsif Is_Record_Type (Typ) and then not Is_Tagged_Type (Typ) then + + -- Record typecodes are encoded as follows: + -- -- TC_STRUCT + -- | + -- | [Name] + -- | [Repository Id] + -- + -- Then for each discriminant: + -- + -- | [Discriminant Type Code] + -- | [Discriminant Name] + -- | ... + -- + -- Then for each component: + -- + -- | [Component Type Code] + -- | [Component Name] + -- | ... + -- + -- Variants components type codes are encoded as follows: + -- -- TC_UNION + -- | + -- | [Name] + -- | [Repository Id] + -- | [Discriminant Type Code] + -- | [Index of Default Variant Part or -1 for no default] + -- + -- Then for each Variant Part : + -- + -- | [VP Label] + -- | + -- | -- TC_STRUCT + -- | | [Variant Part Name] + -- | | [Variant Part Repository Id] + -- | | + -- | Then for each VP component: + -- | | [VP component Typecode] + -- | | [VP component Name] + -- | | ... + -- | -- + -- | + -- | [VP Name] + + if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then + Return_Alias_TypeCode + (Build_TypeCode_Call (Loc, Etype (Typ), Decls)); + + else + declare + Disc : Entity_Id := Empty; + Rdef : constant Node_Id := + Type_Definition (Declaration_Node (Typ)); + Dummy_Counter : Int := 0; + + begin + -- Construct the discriminants typecodes + + if Has_Discriminants (Typ) then + Disc := First_Discriminant (Typ); + end if; + + while Present (Disc) loop + Add_TypeCode_Parameter ( + Build_TypeCode_Call (Loc, Etype (Disc), Decls), + Parameters); + Get_Name_String (Chars (Disc)); + Add_String_Parameter ( + String_From_Name_Buffer, + Parameters); + Next_Discriminant (Disc); + end loop; + + -- then the components typecodes + + TC_Append_Record_Traversal + (Parameters, Component_List (Rdef), + Empty, Dummy_Counter); + Return_Constructed_TypeCode (RTE (RE_TC_Struct)); + end; + end if; + + elsif Is_Array_Type (Typ) then + declare + Ndim : constant Pos := Number_Dimensions (Typ); + Inner_TypeCode : Node_Id; + Constrained : constant Boolean := Is_Constrained (Typ); + Indx : Node_Id := First_Index (Typ); + + begin + Inner_TypeCode := + Build_TypeCode_Call (Loc, Component_Type (Typ), Decls); + + for J in 1 .. Ndim loop + if Constrained then + Inner_TypeCode := Make_Constructed_TypeCode + (RTE (RE_TC_Array), New_List ( + Build_To_Any_Call (Loc, + OK_Convert_To (RTE (RE_Unsigned_32), + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Typ, Loc), + Attribute_Name => Name_Length, + Expressions => New_List ( + Make_Integer_Literal (Loc, + Intval => Ndim - J + 1)))), + Decls), + Build_To_Any_Call (Loc, Inner_TypeCode, Decls))); + + else + -- Unconstrained case: add low bound for each + -- dimension. + + Add_TypeCode_Parameter + (Build_TypeCode_Call (Loc, Etype (Indx), Decls), + Parameters); + Get_Name_String (New_External_Name ('L', J)); + Add_String_Parameter ( + String_From_Name_Buffer, + Parameters); + Next_Index (Indx); + + Inner_TypeCode := Make_Constructed_TypeCode + (RTE (RE_TC_Sequence), New_List ( + Build_To_Any_Call (Loc, + OK_Convert_To (RTE (RE_Unsigned_32), + Make_Integer_Literal (Loc, 0)), + Decls), + Build_To_Any_Call (Loc, Inner_TypeCode, Decls))); + end if; + end loop; + + if Constrained then + Return_Alias_TypeCode (Inner_TypeCode); + else + Add_TypeCode_Parameter (Inner_TypeCode, Parameters); + Start_String; + Store_String_Char ('V'); + Add_String_Parameter (End_String, Parameters); + Return_Constructed_TypeCode (RTE (RE_TC_Struct)); + end if; + end; + + else + -- Default: type is represented as an opaque sequence of bytes + + Return_Alias_TypeCode + (New_Occurrence_Of (RTE (RE_TC_Opaque), Loc)); + end if; + + Decl := + Make_Subprogram_Body (Loc, + Specification => Spec, + Declarations => Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stms)); + end Build_TypeCode_Function; + + --------------------------------- + -- Find_Numeric_Representation -- + --------------------------------- + + function Find_Numeric_Representation + (Typ : Entity_Id) return Entity_Id + is + FST : constant Entity_Id := First_Subtype (Typ); + P_Size : constant Uint := Esize (FST); + + begin + -- Special case: for Stream_Element_Offset and Storage_Offset, + -- always force transmission as a 64-bit value. + + if Is_RTE (FST, RE_Stream_Element_Offset) + or else + Is_RTE (FST, RE_Storage_Offset) + then + return RTE (RE_Unsigned_64); + end if; + + if Is_Unsigned_Type (Typ) then + if P_Size <= 8 then + return RTE (RE_Unsigned_8); + + elsif P_Size <= 16 then + return RTE (RE_Unsigned_16); + + elsif P_Size <= 32 then + return RTE (RE_Unsigned_32); + + else + return RTE (RE_Unsigned_64); + end if; + + elsif Is_Integer_Type (Typ) then + if P_Size <= 8 then + return RTE (RE_Integer_8); + + elsif P_Size <= Standard_Short_Integer_Size then + return RTE (RE_Integer_16); + + elsif P_Size <= Standard_Integer_Size then + return RTE (RE_Integer_32); + + else + return RTE (RE_Integer_64); + end if; + + elsif Is_Floating_Point_Type (Typ) then + if P_Size <= Standard_Short_Float_Size then + return Standard_Short_Float; + + elsif P_Size <= Standard_Float_Size then + return Standard_Float; + + elsif P_Size <= Standard_Long_Float_Size then + return Standard_Long_Float; + + else + return Standard_Long_Long_Float; + end if; + + else + raise Program_Error; + end if; + + -- TBD: fixed point types??? + -- TBverified numeric types with a biased representation??? + + end Find_Numeric_Representation; + + --------------------------- + -- Append_Array_Traversal -- + --------------------------- + + procedure Append_Array_Traversal + (Stmts : List_Id; + Any : Entity_Id; + Counter : Entity_Id := Empty; + Depth : Pos := 1) + is + Loc : constant Source_Ptr := Sloc (Subprogram); + Typ : constant Entity_Id := Etype (Arry); + Constrained : constant Boolean := Is_Constrained (Typ); + Ndim : constant Pos := Number_Dimensions (Typ); + + Inner_Any, Inner_Counter : Entity_Id; + + Loop_Stm : Node_Id; + Inner_Stmts : constant List_Id := New_List; + + begin + if Depth > Ndim then + + -- Processing for one element of an array + + declare + Element_Expr : constant Node_Id := + Make_Indexed_Component (Loc, + New_Occurrence_Of (Arry, Loc), + Indexes); + begin + Set_Etype (Element_Expr, Component_Type (Typ)); + Add_Process_Element (Stmts, + Any => Any, + Counter => Counter, + Datum => Element_Expr); + end; + + return; + end if; + + Append_To (Indexes, + Make_Identifier (Loc, New_External_Name ('L', Depth))); + + if not Constrained or else Depth > 1 then + Inner_Any := Make_Defining_Identifier (Loc, + New_External_Name ('A', Depth)); + Set_Etype (Inner_Any, RTE (RE_Any)); + else + Inner_Any := Empty; + end if; + + if Present (Counter) then + Inner_Counter := Make_Defining_Identifier (Loc, + New_External_Name ('J', Depth)); + else + Inner_Counter := Empty; + end if; + + declare + Loop_Any : Node_Id := Inner_Any; + + begin + -- For the first dimension of a constrained array, we add + -- elements directly in the corresponding Any; there is no + -- intervening inner Any. + + if No (Loop_Any) then + Loop_Any := Any; + end if; + + Append_Array_Traversal (Inner_Stmts, + Any => Loop_Any, + Counter => Inner_Counter, + Depth => Depth + 1); + end; + + Loop_Stm := + Make_Implicit_Loop_Statement (Subprogram, + Iteration_Scheme => + Make_Iteration_Scheme (Loc, + Loop_Parameter_Specification => + Make_Loop_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, + Chars => New_External_Name ('L', Depth)), + + Discrete_Subtype_Definition => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Arry, Loc), + Attribute_Name => Name_Range, + + Expressions => New_List ( + Make_Integer_Literal (Loc, Depth))))), + Statements => Inner_Stmts); + + declare + Decls : constant List_Id := New_List; + Dimen_Stmts : constant List_Id := New_List; + Length_Node : Node_Id; + + Inner_Any_TypeCode : constant Entity_Id := + Make_Defining_Identifier (Loc, + New_External_Name ('T', Depth)); + + Inner_Any_TypeCode_Expr : Node_Id; + + begin + if Depth = 1 then + if Constrained then + Inner_Any_TypeCode_Expr := + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (RE_Get_TC), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Any, Loc))); + + else + Inner_Any_TypeCode_Expr := + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (RTE (RE_Any_Member_Type), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Any, Loc), + Make_Integer_Literal (Loc, Ndim))); + end if; + + else + Inner_Any_TypeCode_Expr := + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (RE_Content_Type), Loc), + Parameter_Associations => New_List ( + Make_Identifier (Loc, + Chars => New_External_Name ('T', Depth - 1)))); + end if; + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Inner_Any_TypeCode, + Constant_Present => True, + Object_Definition => New_Occurrence_Of ( + RTE (RE_TypeCode), Loc), + Expression => Inner_Any_TypeCode_Expr)); + + if Present (Inner_Any) then + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Inner_Any, + Object_Definition => + New_Occurrence_Of (RTE (RE_Any), Loc), + Expression => + Make_Function_Call (Loc, + Name => + New_Occurrence_Of ( + RTE (RE_Create_Any), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Inner_Any_TypeCode, Loc))))); + end if; + + if Present (Inner_Counter) then + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Inner_Counter, + Object_Definition => + New_Occurrence_Of (RTE (RE_Unsigned_32), Loc), + Expression => + Make_Integer_Literal (Loc, 0))); + end if; + + if not Constrained then + Length_Node := Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Arry, Loc), + Attribute_Name => Name_Length, + Expressions => + New_List (Make_Integer_Literal (Loc, Depth))); + Set_Etype (Length_Node, RTE (RE_Unsigned_32)); + + Add_Process_Element (Dimen_Stmts, + Datum => Length_Node, + Any => Inner_Any, + Counter => Inner_Counter); + end if; + + -- Loop_Stm does appropriate processing for each element + -- of Inner_Any. + + Append_To (Dimen_Stmts, Loop_Stm); + + -- Link outer and inner any + + if Present (Inner_Any) then + Add_Process_Element (Dimen_Stmts, + Any => Any, + Counter => Counter, + Datum => New_Occurrence_Of (Inner_Any, Loc)); + end if; + + Append_To (Stmts, + Make_Block_Statement (Loc, + Declarations => + Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Dimen_Stmts))); + end; + end Append_Array_Traversal; + + ------------------------------- + -- Make_Helper_Function_Name -- + ------------------------------- + + function Make_Helper_Function_Name + (Loc : Source_Ptr; + Typ : Entity_Id; + Nam : Name_Id) return Entity_Id + is + begin + declare + Serial : Nat := 0; + -- For tagged types that aren't frozen yet, generate the helper + -- under its canonical name so that it matches the primitive + -- spec. For all other cases, we use a serialized name so that + -- multiple generations of the same procedure do not clash. + + begin + if Is_Tagged_Type (Typ) and then not Is_Frozen (Typ) then + null; + else + Serial := Increment_Serial_Number; + end if; + + -- Use prefixed underscore to avoid potential clash with user + -- identifier (we use attribute names for Nam). + + return + Make_Defining_Identifier (Loc, + Chars => + New_External_Name + (Related_Id => Nam, + Suffix => ' ', + Suffix_Index => Serial, + Prefix => '_')); + end; + end Make_Helper_Function_Name; + end Helpers; + + ----------------------------------- + -- Reserve_NamingContext_Methods -- + ----------------------------------- + + procedure Reserve_NamingContext_Methods is + Str_Resolve : constant String := "resolve"; + begin + Name_Buffer (1 .. Str_Resolve'Length) := Str_Resolve; + Name_Len := Str_Resolve'Length; + Overload_Counter_Table.Set (Name_Find, 1); + end Reserve_NamingContext_Methods; + + ----------------------- + -- RPC_Receiver_Decl -- + ----------------------- + + function RPC_Receiver_Decl (RACW_Type : Entity_Id) return Node_Id is + Loc : constant Source_Ptr := Sloc (RACW_Type); + begin + return + Make_Object_Declaration (Loc, + Defining_Identifier => Make_Temporary (Loc, 'R'), + Aliased_Present => True, + Object_Definition => New_Occurrence_Of (RTE (RE_Servant), Loc)); + end RPC_Receiver_Decl; + + end PolyORB_Support; + + ------------------------------- + -- RACW_Type_Is_Asynchronous -- + ------------------------------- + + procedure RACW_Type_Is_Asynchronous (RACW_Type : Entity_Id) is + Asynchronous_Flag : constant Entity_Id := + Asynchronous_Flags_Table.Get (RACW_Type); + begin + Replace (Expression (Parent (Asynchronous_Flag)), + New_Occurrence_Of (Standard_True, Sloc (Asynchronous_Flag))); + end RACW_Type_Is_Asynchronous; + + ------------------------- + -- RCI_Package_Locator -- + ------------------------- + + function RCI_Package_Locator + (Loc : Source_Ptr; + Package_Spec : Node_Id) return Node_Id + is + Inst : Node_Id; + Pkg_Name : String_Id; + + begin + Get_Library_Unit_Name_String (Package_Spec); + Pkg_Name := String_From_Name_Buffer; + Inst := + Make_Package_Instantiation (Loc, + Defining_Unit_Name => Make_Temporary (Loc, 'R'), + + Name => + New_Occurrence_Of (RTE (RE_RCI_Locator), Loc), + + Generic_Associations => New_List ( + Make_Generic_Association (Loc, + Selector_Name => + Make_Identifier (Loc, Name_RCI_Name), + Explicit_Generic_Actual_Parameter => + Make_String_Literal (Loc, + Strval => Pkg_Name)), + + Make_Generic_Association (Loc, + Selector_Name => + Make_Identifier (Loc, Name_Version), + Explicit_Generic_Actual_Parameter => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Defining_Entity (Package_Spec), Loc), + Attribute_Name => + Name_Version)))); + + RCI_Locator_Table.Set + (Defining_Unit_Name (Package_Spec), + Defining_Unit_Name (Inst)); + return Inst; + end RCI_Package_Locator; + + ----------------------------------------------- + -- Remote_Types_Tagged_Full_View_Encountered -- + ----------------------------------------------- + + procedure Remote_Types_Tagged_Full_View_Encountered + (Full_View : Entity_Id) + is + Stub_Elements : constant Stub_Structure := + Stubs_Table.Get (Full_View); + + begin + -- For an RACW encountered before the freeze point of its designated + -- type, the stub type is generated at the point of the RACW declaration + -- but the primitives are generated only once the designated type is + -- frozen. That freeze can occur in another scope, for example when the + -- RACW is declared in a nested package. In that case we need to + -- reestablish the stub type's scope prior to generating its primitive + -- operations. + + if Stub_Elements /= Empty_Stub_Structure then + declare + Saved_Scope : constant Entity_Id := Current_Scope; + Stubs_Scope : constant Entity_Id := + Scope (Stub_Elements.Stub_Type); + + begin + if Current_Scope /= Stubs_Scope then + Push_Scope (Stubs_Scope); + end if; + + Add_RACW_Primitive_Declarations_And_Bodies + (Full_View, + Stub_Elements.RPC_Receiver_Decl, + Stub_Elements.Body_Decls); + + if Current_Scope /= Saved_Scope then + Pop_Scope; + end if; + end; + end if; + end Remote_Types_Tagged_Full_View_Encountered; + + ------------------- + -- Scope_Of_Spec -- + ------------------- + + function Scope_Of_Spec (Spec : Node_Id) return Entity_Id is + Unit_Name : Node_Id; + + begin + Unit_Name := Defining_Unit_Name (Spec); + while Nkind (Unit_Name) /= N_Defining_Identifier loop + Unit_Name := Defining_Identifier (Unit_Name); + end loop; + + return Unit_Name; + end Scope_Of_Spec; + + ---------------------- + -- Set_Renaming_TSS -- + ---------------------- + + procedure Set_Renaming_TSS + (Typ : Entity_Id; + Nam : Entity_Id; + TSS_Nam : TSS_Name_Type) + is + Loc : constant Source_Ptr := Sloc (Nam); + Spec : constant Node_Id := Parent (Nam); + + TSS_Node : constant Node_Id := + Make_Subprogram_Renaming_Declaration (Loc, + Specification => + Copy_Specification (Loc, + Spec => Spec, + New_Name => Make_TSS_Name (Typ, TSS_Nam)), + Name => New_Occurrence_Of (Nam, Loc)); + + Snam : constant Entity_Id := + Defining_Unit_Name (Specification (TSS_Node)); + + begin + if Nkind (Spec) = N_Function_Specification then + Set_Ekind (Snam, E_Function); + Set_Etype (Snam, Entity (Result_Definition (Spec))); + else + Set_Ekind (Snam, E_Procedure); + Set_Etype (Snam, Standard_Void_Type); + end if; + + Set_TSS (Typ, Snam); + end Set_Renaming_TSS; + + ---------------------------------------------- + -- Specific_Add_Obj_RPC_Receiver_Completion -- + ---------------------------------------------- + + procedure Specific_Add_Obj_RPC_Receiver_Completion + (Loc : Source_Ptr; + Decls : List_Id; + RPC_Receiver : Entity_Id; + Stub_Elements : Stub_Structure) + is + begin + case Get_PCS_Name is + when Name_PolyORB_DSA => + PolyORB_Support.Add_Obj_RPC_Receiver_Completion + (Loc, Decls, RPC_Receiver, Stub_Elements); + when others => + GARLIC_Support.Add_Obj_RPC_Receiver_Completion + (Loc, Decls, RPC_Receiver, Stub_Elements); + end case; + end Specific_Add_Obj_RPC_Receiver_Completion; + + -------------------------------- + -- Specific_Add_RACW_Features -- + -------------------------------- + + procedure Specific_Add_RACW_Features + (RACW_Type : Entity_Id; + Desig : Entity_Id; + Stub_Type : Entity_Id; + Stub_Type_Access : Entity_Id; + RPC_Receiver_Decl : Node_Id; + Body_Decls : List_Id) + is + begin + case Get_PCS_Name is + when Name_PolyORB_DSA => + PolyORB_Support.Add_RACW_Features + (RACW_Type, + Desig, + Stub_Type, + Stub_Type_Access, + RPC_Receiver_Decl, + Body_Decls); + + when others => + GARLIC_Support.Add_RACW_Features + (RACW_Type, + Stub_Type, + Stub_Type_Access, + RPC_Receiver_Decl, + Body_Decls); + end case; + end Specific_Add_RACW_Features; + + -------------------------------- + -- Specific_Add_RAST_Features -- + -------------------------------- + + procedure Specific_Add_RAST_Features + (Vis_Decl : Node_Id; + RAS_Type : Entity_Id) + is + begin + case Get_PCS_Name is + when Name_PolyORB_DSA => + PolyORB_Support.Add_RAST_Features (Vis_Decl, RAS_Type); + when others => + GARLIC_Support.Add_RAST_Features (Vis_Decl, RAS_Type); + end case; + end Specific_Add_RAST_Features; + + -------------------------------------------------- + -- Specific_Add_Receiving_Stubs_To_Declarations -- + -------------------------------------------------- + + procedure Specific_Add_Receiving_Stubs_To_Declarations + (Pkg_Spec : Node_Id; + Decls : List_Id; + Stmts : List_Id) + is + begin + case Get_PCS_Name is + when Name_PolyORB_DSA => + PolyORB_Support.Add_Receiving_Stubs_To_Declarations + (Pkg_Spec, Decls, Stmts); + when others => + GARLIC_Support.Add_Receiving_Stubs_To_Declarations + (Pkg_Spec, Decls, Stmts); + end case; + end Specific_Add_Receiving_Stubs_To_Declarations; + + ------------------------------------------ + -- Specific_Build_General_Calling_Stubs -- + ------------------------------------------ + + procedure Specific_Build_General_Calling_Stubs + (Decls : List_Id; + Statements : List_Id; + Target : RPC_Target; + Subprogram_Id : Node_Id; + Asynchronous : Node_Id := Empty; + Is_Known_Asynchronous : Boolean := False; + Is_Known_Non_Asynchronous : Boolean := False; + Is_Function : Boolean; + Spec : Node_Id; + Stub_Type : Entity_Id := Empty; + RACW_Type : Entity_Id := Empty; + Nod : Node_Id) + is + begin + case Get_PCS_Name is + when Name_PolyORB_DSA => + PolyORB_Support.Build_General_Calling_Stubs + (Decls, + Statements, + Target.Object, + Subprogram_Id, + Asynchronous, + Is_Known_Asynchronous, + Is_Known_Non_Asynchronous, + Is_Function, + Spec, + Stub_Type, + RACW_Type, + Nod); + + when others => + GARLIC_Support.Build_General_Calling_Stubs + (Decls, + Statements, + Target.Partition, + Target.RPC_Receiver, + Subprogram_Id, + Asynchronous, + Is_Known_Asynchronous, + Is_Known_Non_Asynchronous, + Is_Function, + Spec, + Stub_Type, + RACW_Type, + Nod); + end case; + end Specific_Build_General_Calling_Stubs; + + -------------------------------------- + -- Specific_Build_RPC_Receiver_Body -- + -------------------------------------- + + procedure Specific_Build_RPC_Receiver_Body + (RPC_Receiver : Entity_Id; + Request : out Entity_Id; + Subp_Id : out Entity_Id; + Subp_Index : out Entity_Id; + Stmts : out List_Id; + Decl : out Node_Id) + is + begin + case Get_PCS_Name is + when Name_PolyORB_DSA => + PolyORB_Support.Build_RPC_Receiver_Body + (RPC_Receiver, + Request, + Subp_Id, + Subp_Index, + Stmts, + Decl); + + when others => + GARLIC_Support.Build_RPC_Receiver_Body + (RPC_Receiver, + Request, + Subp_Id, + Subp_Index, + Stmts, + Decl); + end case; + end Specific_Build_RPC_Receiver_Body; + + -------------------------------- + -- Specific_Build_Stub_Target -- + -------------------------------- + + function Specific_Build_Stub_Target + (Loc : Source_Ptr; + Decls : List_Id; + RCI_Locator : Entity_Id; + Controlling_Parameter : Entity_Id) return RPC_Target + is + begin + case Get_PCS_Name is + when Name_PolyORB_DSA => + return + PolyORB_Support.Build_Stub_Target + (Loc, Decls, RCI_Locator, Controlling_Parameter); + + when others => + return + GARLIC_Support.Build_Stub_Target + (Loc, Decls, RCI_Locator, Controlling_Parameter); + end case; + end Specific_Build_Stub_Target; + + -------------------------------- + -- Specific_RPC_Receiver_Decl -- + -------------------------------- + + function Specific_RPC_Receiver_Decl + (RACW_Type : Entity_Id) return Node_Id + is + begin + case Get_PCS_Name is + when Name_PolyORB_DSA => + return PolyORB_Support.RPC_Receiver_Decl (RACW_Type); + + when others => + return GARLIC_Support.RPC_Receiver_Decl (RACW_Type); + end case; + end Specific_RPC_Receiver_Decl; + + ----------------------------------------------- + -- Specific_Build_Subprogram_Receiving_Stubs -- + ----------------------------------------------- + + function Specific_Build_Subprogram_Receiving_Stubs + (Vis_Decl : Node_Id; + Asynchronous : Boolean; + Dynamically_Asynchronous : Boolean := False; + Stub_Type : Entity_Id := Empty; + RACW_Type : Entity_Id := Empty; + Parent_Primitive : Entity_Id := Empty) return Node_Id + is + begin + case Get_PCS_Name is + when Name_PolyORB_DSA => + return + PolyORB_Support.Build_Subprogram_Receiving_Stubs + (Vis_Decl, + Asynchronous, + Dynamically_Asynchronous, + Stub_Type, + RACW_Type, + Parent_Primitive); + + when others => + return + GARLIC_Support.Build_Subprogram_Receiving_Stubs + (Vis_Decl, + Asynchronous, + Dynamically_Asynchronous, + Stub_Type, + RACW_Type, + Parent_Primitive); + end case; + end Specific_Build_Subprogram_Receiving_Stubs; + + ------------------------------- + -- Transmit_As_Unconstrained -- + ------------------------------- + + function Transmit_As_Unconstrained (Typ : Entity_Id) return Boolean is + begin + return + not (Is_Elementary_Type (Typ) or else Is_Constrained (Typ)) + or else (Is_Access_Type (Typ) and then Can_Never_Be_Null (Typ)); + end Transmit_As_Unconstrained; + + -------------------------- + -- Underlying_RACW_Type -- + -------------------------- + + function Underlying_RACW_Type (RAS_Typ : Entity_Id) return Entity_Id is + Record_Type : Entity_Id; + + begin + if Ekind (RAS_Typ) = E_Record_Type then + Record_Type := RAS_Typ; + else + pragma Assert (Present (Equivalent_Type (RAS_Typ))); + Record_Type := Equivalent_Type (RAS_Typ); + end if; + + return + Etype (Subtype_Indication + (Component_Definition + (First (Component_Items + (Component_List + (Type_Definition + (Declaration_Node (Record_Type)))))))); + end Underlying_RACW_Type; + +end Exp_Dist; |