diff options
Diffstat (limited to 'gcc-4.4.3/gcc/ada/exp_dist.adb')
| -rw-r--r-- | gcc-4.4.3/gcc/ada/exp_dist.adb | 11487 |
1 files changed, 0 insertions, 11487 deletions
diff --git a/gcc-4.4.3/gcc/ada/exp_dist.adb b/gcc-4.4.3/gcc/ada/exp_dist.adb deleted file mode 100644 index 546bbcc57..000000000 --- a/gcc-4.4.3/gcc/ada/exp_dist.adb +++ /dev/null @@ -1,11487 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- E X P_ D I S T -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2008, 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_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_Cat; use Sem_Cat; -with Sem_Ch3; use Sem_Ch3; -with Sem_Ch8; use Sem_Ch8; -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 than 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 arrive 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 names. 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 use 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; - Decls : List_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 out parameter). - - 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, for the case of 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. - - procedure Specific_Build_Stub_Type - (RACW_Type : Entity_Id; - Stub_Type : Entity_Id; - Stub_Type_Decl : out Node_Id; - RPC_Receiver_Decl : out Node_Id); - -- Build a type declaration for the stub type associated with an RACW - -- type, and the necessary RPC receiver, if applicable. PCS-specific - -- ancillary subprogram for Add_Stub_Type. If no RPC receiver declaration - -- is generated, then RPC_Receiver_Decl is set to 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 - - 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; - - procedure Build_Stub_Type - (RACW_Type : Entity_Id; - Stub_Type : Entity_Id; - Stub_Type_Decl : out Node_Id; - RPC_Receiver_Decl : out 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; - - 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; - - procedure Build_Stub_Type - (RACW_Type : Entity_Id; - Stub_Type : Entity_Id; - Stub_Type_Decl : out Node_Id; - RPC_Receiver_Decl : out 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). - - 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 - (N : Node_Id; - Decls : List_Id) return Node_Id; - -- Build call to To_Any attribute function with expression as actual - -- parameter. 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_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 - -- conversion 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. - - 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 - (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). - - --------------------------------------- - -- Add_Calling_Stubs_To_Declarations -- - --------------------------------------- - - procedure Add_Calling_Stubs_To_Declarations - (Pkg_Spec : Node_Id; - Decls : List_Id) - is - Current_Subprogram_Number : Int := First_RCI_Subprogram_Id; - -- Subprogram id 0 is reserved for calls received from - -- remote access-to-subprogram dereferences. - - Current_Declaration : Node_Id; - Loc : constant Source_Ptr := Sloc (Pkg_Spec); - RCI_Instantiation : Node_Id; - Subp_Stubs : Node_Id; - Subp_Str : String_Id; - - pragma Warnings (Off, Subp_Str); - - begin - -- 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 (Decls, 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 subprograms. The receiving stubs processing do use the same - -- mechanism and will thus assign the same Id and do the correct - -- dispatching. - - Overload_Counter_Table.Reset; - PolyORB_Support.Reserve_NamingContext_Methods; - - Current_Declaration := First (Visible_Declarations (Pkg_Spec)); - while Present (Current_Declaration) loop - if Nkind (Current_Declaration) = N_Subprogram_Declaration - and then Comes_From_Source (Current_Declaration) - then - Assign_Subprogram_Identifier - (Defining_Unit_Name (Specification (Current_Declaration)), - Current_Subprogram_Number, - Subp_Str); - - Subp_Stubs := - Build_Subprogram_Calling_Stubs ( - Vis_Decl => Current_Declaration, - Subp_Id => - Build_Subprogram_Id (Loc, - Defining_Unit_Name (Specification (Current_Declaration))), - Asynchronous => - Nkind (Specification (Current_Declaration)) = - N_Procedure_Specification - and then - Is_Asynchronous (Defining_Unit_Name (Specification - (Current_Declaration)))); - - Append_To (Decls, Subp_Stubs); - Analyze (Subp_Stubs); - - Current_Subprogram_Number := Current_Subprogram_Number + 1; - end if; - - Next (Current_Declaration); - end loop; - 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_Defining_Identifier (Loc, - Chars => New_Internal_Name ('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. - - if Present (Primitive_Operations (Designated_Type)) then - Overload_Counter_Table.Reset; - - Current_Primitive_Elmt := - First_Elmt (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)) - 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 Designated_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 := Current_Primitive; - while Present (Alias (Current_Primitive_Alias)) loop - pragma Assert - (Current_Primitive_Alias - /= Alias (Current_Primitive_Alias)); - Current_Primitive_Alias := Alias (Current_Primitive_Alias); - end loop; - - -- 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 Designated_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_Defining_Identifier (Loc, - Chars => New_Internal_Name ('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_Defining_Identifier (Loc, - Chars => New_Internal_Name ('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')); - - Specific_Build_Stub_Type - (RACW_Type, Stub_Type, - Stub_Type_Decl, RPC_Receiver_Decl); - - 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)); - - -- This is in no way a type derivation, but we fake it to make sure that - -- the dispatching table gets built with the corresponding primitive - -- operations at the right place. - - Derive_Subprograms (Parent_Type => Designated_Type, - Derived_Type => Stub_Type); - - if Present (RPC_Receiver_Decl) then - Append_To (Decls, RPC_Receiver_Decl); - else - 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_Defining_Identifier (Loc, - New_Internal_Name ('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 - Called_Subprogram : constant Entity_Id := Entity (Name (N)); - RCI_Package : constant Entity_Id := Scope (Called_Subprogram); - Loc : constant Source_Ptr := Sloc (N); - RCI_Locator : Node_Id; - RCI_Cache : 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_Cache := RCI_Locator_Table.Get (RCI_Package); - - if RCI_Cache = Empty then - RCI_Locator := - RCI_Package_Locator - (Loc, Specification (Unit_Declaration_Node (RCI_Package))); - Prepend_To (Current_Sem_Unit_Declarations, RCI_Locator); - - -- The RCI_Locator package 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; - - Analyze (RCI_Locator); - Pop_Scope; - end; - - RCI_Cache := Defining_Unit_Name (RCI_Locator); - - else - RCI_Locator := Parent (RCI_Cache); - 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_Cache, - New_Name => New_Internal_Name ('S')); - Insert_After (RCI_Locator, Calling_Stubs); - Analyze (Calling_Stubs); - 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); - Decls : constant List_Id := Visible_Declarations (Spec); - begin - Push_Scope (Scope_Of_Spec (Spec)); - Add_Calling_Stubs_To_Declarations - (Specification (Unit_Node), Decls); - Pop_Scope; - 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_Defining_Identifier - (Loc, New_Internal_Name ('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_Defining_Identifier (Loc, New_Internal_Name ('P')); - Source_Receiver := - Make_Defining_Identifier (Loc, New_Internal_Name ('S')); - Source_Address := - Make_Defining_Identifier (Loc, New_Internal_Name ('P')); - Local_Stub := - Make_Defining_Identifier (Loc, New_Internal_Name ('L')); - Stubbed_Result := - Make_Defining_Identifier (Loc, New_Internal_Name ('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_Defining_Identifier (Loc, New_Internal_Name ('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_Defining_Identifier (Loc, - Chars => New_Internal_Name ('P')); - - -- Additional local variables for the local case - - Proxy_Addr : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('P')); - - -- Additional local variables for the remote case - - Local_Stub : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('L')); - - Stub_Ptr : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('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 Warnings (Off); - pragma Unreferenced (RAS_Type); - pragma Warnings (On); - 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_Defining_Identifier (Loc, - New_Internal_Name ('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_Info : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('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_Declaration : Node_Id; - Current_Subprogram_Number : Int := First_RCI_Subprogram_Id; - Current_Stubs : Node_Id; - - Subp_Info_Array : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('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. - - --------------------- - -- 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; - - -- 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 - - Current_Declaration := - 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, Current_Declaration); - Analyze (Current_Declaration); - - Current_Stubs := Build_Subprogram_Receiving_Stubs - (Vis_Decl => Current_Declaration, - 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; - - Current_Declaration := First (Visible_Declarations (Pkg_Spec)); - while Present (Current_Declaration) loop - if Nkind (Current_Declaration) = N_Subprogram_Declaration - and then Comes_From_Source (Current_Declaration) - then - declare - Loc : constant Source_Ptr := Sloc (Current_Declaration); - -- While specifically processing Current_Declaration, use - -- its Sloc as the location of all generated nodes. - - Subp_Def : constant Entity_Id := - Defining_Unit_Name - (Specification (Current_Declaration)); - - Subp_Val : String_Id; - pragma Warnings (Off, Subp_Val); - - begin - -- Build receiving stub - - Current_Stubs := - Build_Subprogram_Receiving_Stubs - (Vis_Decl => Current_Declaration, - Asynchronous => - Nkind (Specification (Current_Declaration)) = - 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 => Current_Declaration, - All_Calls_Remote_E => All_Calls_Remote_E, - Proxy_Object_Addr => Proxy_Object_Addr); - - -- Compute distribution identifier - - Assign_Subprogram_Identifier - (Subp_Def, - Current_Subprogram_Number, - Subp_Val); - - pragma Assert - (Current_Subprogram_Number = Get_Subprogram_Id (Subp_Def)); - - -- Add subprogram descriptor (RCI_Subp_Info) to the - -- subprograms table for this receiver. The aggregate - -- below must be kept consistent with the declaration - -- of type RCI_Subp_Info in System.Partition_Interface. - - Append_To (Subp_Info_List, - Make_Component_Association (Loc, - Choices => New_List ( - Make_Integer_Literal (Loc, - Current_Subprogram_Number)), - - Expression => - Make_Aggregate (Loc, - Component_Associations => New_List ( - 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_Subprogram_Number); - end; - - Current_Subprogram_Number := Current_Subprogram_Number + 1; - end if; - - Next (Current_Declaration); - end loop; - - -- 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 Warnings (Off); - pragma Unreferenced (RACW_Type); - -- Used only for the PolyORB case - pragma Warnings (On); - - 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_Defining_Identifier (Loc, New_Internal_Name ('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_Defining_Identifier (Loc, New_Internal_Name ('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_Defining_Identifier (Loc, New_Internal_Name ('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_Defining_Identifier - (Loc, New_Internal_Name ('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_Defining_Identifier (Loc, New_Internal_Name ('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_Defining_Identifier (Loc, New_Internal_Name ('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_Stub_Type -- - --------------------- - - procedure Build_Stub_Type - (RACW_Type : Entity_Id; - Stub_Type : Entity_Id; - Stub_Type_Decl : out Node_Id; - RPC_Receiver_Decl : out Node_Id) - is - Loc : constant Source_Ptr := Sloc (Stub_Type); - Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type); - - begin - 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 => New_List ( - - Make_Component_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_Origin), - Component_Definition => - Make_Component_Definition (Loc, - Aliased_Present => False, - Subtype_Indication => - New_Occurrence_Of ( - RTE (RE_Partition_ID), Loc))), - - Make_Component_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_Receiver), - Component_Definition => - Make_Component_Definition (Loc, - Aliased_Present => False, - Subtype_Indication => - New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))), - - Make_Component_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_Addr), - Component_Definition => - Make_Component_Definition (Loc, - Aliased_Present => False, - Subtype_Indication => - New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))), - - Make_Component_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_Asynchronous), - Component_Definition => - Make_Component_Definition (Loc, - Aliased_Present => False, - Subtype_Indication => - New_Occurrence_Of ( - Standard_Boolean, Loc))))))); - - if Is_RAS then - RPC_Receiver_Decl := Empty; - else - declare - RPC_Receiver_Request : constant Entity_Id := - Make_Defining_Identifier (Loc, Name_R); - begin - RPC_Receiver_Decl := - Make_Subprogram_Declaration (Loc, - Build_RPC_Receiver_Specification ( - RPC_Receiver => Make_Defining_Identifier (Loc, - New_Internal_Name ('R')), - Request_Parameter => RPC_Receiver_Request)); - end; - end if; - end Build_Stub_Type; - - -------------------------------------- - -- 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_Defining_Identifier (Loc, - New_Internal_Name ('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_Defining_Identifier (Loc, New_Internal_Name ('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_Defining_Identifier (Loc, - New_Internal_Name ('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_Defining_Identifier (Loc, - New_Internal_Name ('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_Defining_Identifier (Loc, New_Internal_Name ('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_Defining_Identifier (Loc, New_Internal_Name ('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; - - ---------------------- - -- 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_Defining_Identifier (Loc, New_Internal_Name ('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_Defining_Identifier (Loc, New_Internal_Name ('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, - Full_Qualified_Name (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 Warnings (Off); - pragma Unreferenced (RPC_Receiver_Decl); - pragma Warnings (On); - - 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 Warnings (Off); - pragma Unreferenced (Stub_Type, Stub_Type_Access); - pragma Warnings (On); - 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_Defining_Identifier (Loc, - New_Internal_Name ('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_Defining_Identifier - (Loc, New_Internal_Name ('R')); - Any : constant Entity_Id := - Make_Defining_Identifier - (Loc, New_Internal_Name ('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 => Full_Qualified_Name - (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 Warnings (Off); - pragma Unreferenced (Stub_Type, Stub_Type_Access); - pragma Warnings (On); - - 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_Defining_Identifier (Loc, New_Internal_Name ('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 => Full_Qualified_Name - (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 - - -- Additional local variables for the remote case - - Local_Stub : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('L')); - - Stub_Ptr : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('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 => 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); - - 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)))))), - - -- end if; - -- 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_Defining_Identifier (Loc, - Chars => New_Internal_Name ('A')); - RAS_Parameter : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('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 - (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_String), Loc), - Parameter_Associations => New_List ( - Make_String_Literal (Loc, Name_String))), - Make_Function_Call (Loc, - Name => - New_Occurrence_Of - (RTE (RE_TA_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_Defining_Identifier (Loc, - New_Internal_Name ('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_Defining_Identifier (Loc, - Chars => New_Internal_Name ('L')); - - Local_Address : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('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_Declaration : Node_Id; - Current_Stubs : Node_Id; - Current_Subprogram_Number : Int := First_RCI_Subprogram_Id; - - Subp_Info_Array : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('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. - - --------------------- - -- 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; - - -- 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, - 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; - - Current_Declaration := First (Visible_Declarations (Pkg_Spec)); - while Present (Current_Declaration) loop - if Nkind (Current_Declaration) = N_Subprogram_Declaration - and then Comes_From_Source (Current_Declaration) - then - declare - Loc : constant Source_Ptr := Sloc (Current_Declaration); - -- While specifically processing Current_Declaration, use - -- its Sloc as the location of all generated nodes. - - Subp_Def : constant Entity_Id := - Defining_Unit_Name - (Specification (Current_Declaration)); - - 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)); - - Proxy_Object_Addr : Entity_Id; - - begin - -- Build receiving stub - - Current_Stubs := - Build_Subprogram_Receiving_Stubs - (Vis_Decl => Current_Declaration, - Asynchronous => - Nkind (Specification (Current_Declaration)) = - 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 => Current_Declaration, - All_Calls_Remote_E => All_Calls_Remote_E, - Proxy_Object_Addr => Proxy_Object_Addr); - - -- Compute distribution identifier - - Assign_Subprogram_Identifier - (Subp_Def, - Current_Subprogram_Number, - Subp_Val); - - pragma Assert - (Current_Subprogram_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 type RCI_Subp_Info in System.Partition_Interface. - - Append_To (Subp_Info_List, - Make_Component_Association (Loc, - Choices => New_List ( - Make_Integer_Literal (Loc, Current_Subprogram_Number)), - - Expression => - Make_Aggregate (Loc, - Expressions => New_List ( - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Subp_Dist_Name, Loc), - Attribute_Name => Name_Address), - - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Subp_Dist_Name, Loc), - Attribute_Name => Name_Length), - - New_Occurrence_Of (Proxy_Object_Addr, Loc))))); - - Append_Stubs_To (Pkg_RPC_Receiver_Cases, - Declaration => Current_Declaration, - Stubs => Current_Stubs, - Subp_Number => Current_Subprogram_Number, - Subp_Dist_Name => Subp_Dist_Name, - Subp_Proxy_Addr => Proxy_Object_Addr); - end; - - Current_Subprogram_Number := Current_Subprogram_Number + 1; - end if; - - Next (Current_Declaration); - end loop; - - 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_Defining_Identifier (Loc, New_Internal_Name ('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)); - - -- ??? - - 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); - - Arguments : Node_Id; - -- Name of the named values list used to transmit parameters - -- to the remote package - - Request : Node_Id; - -- The request object constructed by these stubs - - 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 - Request := Make_Defining_Identifier (Loc, New_Internal_Name ('R')); - - Append_To (Decls, - Make_Object_Declaration (Loc, - Defining_Identifier => Request, - Aliased_Present => False, - Object_Definition => - New_Occurrence_Of (RTE (RE_Request_Access), Loc))); - - Result := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('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_Defining_Identifier (Loc, New_Internal_Name ('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_Defining_Identifier (Loc, New_Internal_Name ('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_Defining_Identifier (Loc, - New_Internal_Name ('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 - (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 - 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 - (Etype (Parameter_Type (Current_Parameter)), - New_Occurrence_Of (Any, Loc), - Decls))); - - 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_Defining_Identifier - (Loc, New_Internal_Name ('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 - (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_Create), Loc), - - Parameter_Associations => New_List ( - Target_Object, - Subprogram_Id, - New_Occurrence_Of (Arguments, Loc), - New_Occurrence_Of (Result, Loc), - New_Occurrence_Of (RTE (RE_Nil_Exc_List), Loc)))); - - Append_To (Parameter_Associations (Last (Statements)), - New_Occurrence_Of (Request, 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_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (RTE (RE_Request_Invoke), Loc), - Parameter_Associations => New_List ( - New_Occurrence_Of (Request, Loc)))); - - Non_Asynchronous_Statements := New_List (Make_Null_Statement (Loc)); - Asynchronous_Statements := New_List (Make_Null_Statement (Loc)); - - 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. - - Append_To (Non_Asynchronous_Statements, - 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)))); - end if; - end if; - - Append_List_To (Non_Asynchronous_Statements, After_Statements); - - 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_Defining_Identifier (Loc, - New_Internal_Name ('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_Stub_Type -- - --------------------- - - procedure Build_Stub_Type - (RACW_Type : Entity_Id; - Stub_Type : Entity_Id; - Stub_Type_Decl : out Node_Id; - RPC_Receiver_Decl : out Node_Id) - is - Loc : constant Source_Ptr := Sloc (Stub_Type); - pragma Warnings (Off); - pragma Unreferenced (RACW_Type); - pragma Warnings (On); - - begin - 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 => New_List ( - - Make_Component_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_Target), - Component_Definition => - Make_Component_Definition (Loc, - Aliased_Present => False, - Subtype_Indication => - New_Occurrence_Of (RTE (RE_Entity_Ptr), Loc))), - - Make_Component_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_Asynchronous), - - Component_Definition => - Make_Component_Definition (Loc, - Aliased_Present => False, - Subtype_Indication => - New_Occurrence_Of (Standard_Boolean, Loc))))))); - - RPC_Receiver_Decl := - Make_Object_Declaration (Loc, - Defining_Identifier => Make_Defining_Identifier (Loc, - New_Internal_Name ('R')), - Aliased_Present => True, - Object_Definition => - New_Occurrence_Of (RTE (RE_Servant), Loc)); - end Build_Stub_Type; - - ----------------------------- - -- 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_Defining_Identifier (Loc, - New_Internal_Name ('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_Defining_Identifier (Loc, - New_Internal_Name ('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_Defining_Identifier (Loc, - Chars => New_Internal_Name ('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_Defining_Identifier (Loc, - Chars => New_Internal_Name ('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_Defining_Identifier (Loc, - Chars => New_Internal_Name ('A')); - - Is_Local : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('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. - - Expr := PolyORB_Support.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 - null; - - -- Expr will be used to initialize (and constrain) the - -- parameter when it is declared. - 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 - (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 => - 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)); - - Extra_Any : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('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_Defining_Identifier (Loc, - Chars => New_Internal_Name ('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 - (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_Defining_Identifier (Loc, New_Internal_Name ('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 floating - -- point type from Standard, or the smallest unsigned (modular) type - -- from System.Unsigned_Types, 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 - - Indices : 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; Indices is the list of indices 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; - - ------------------------- - -- 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); - - if Sloc (U_Type) <= Standard_Location then - U_Type := Base_Type (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 = Etype (Standard_Short_Short_Integer) then - Lib_RE := RE_FA_SSI; - - elsif U_Type = Etype (Standard_Short_Integer) then - Lib_RE := RE_FA_SI; - - elsif U_Type = Etype (Standard_Integer) then - Lib_RE := RE_FA_I; - - elsif U_Type = Etype (Standard_Long_Integer) then - Lib_RE := RE_FA_LI; - - elsif U_Type = Etype (Standard_Long_Long_Integer) then - Lib_RE := RE_FA_LLI; - - -- Unsigned integer types - - elsif U_Type = RTE (RE_Short_Short_Unsigned) then - Lib_RE := RE_FA_SSU; - - elsif U_Type = RTE (RE_Short_Unsigned) then - Lib_RE := RE_FA_SU; - - elsif U_Type = RTE (RE_Unsigned) then - Lib_RE := RE_FA_U; - - elsif U_Type = RTE (RE_Long_Unsigned) then - Lib_RE := RE_FA_LU; - - elsif U_Type = RTE (RE_Long_Long_Unsigned) then - Lib_RE := RE_FA_LLU; - - elsif U_Type = Standard_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_Defining_Identifier (Loc, - New_Internal_Name ('A')); - - Use_Opaque_Representation : Boolean; - - begin - if Is_Itype (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 following 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 => - OK_Convert_To (Typ, - 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_Defining_Identifier (Loc, - New_Internal_Name ('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 - begin - if Nkind (Field) = N_Defining_Identifier then - - -- A regular component - - 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 (Etype (Field), - Build_Get_Aggregate_Element (Loc, - Any => Any, - TC => Build_TypeCode_Call (Loc, - Etype (Field), 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_Defining_Identifier (Loc, - New_Internal_Name ('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, - Indices => 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); - Indt := 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_Long_Unsigned), 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 - - -- Default: type is represented as an opaque sequence of bytes - - declare - Strm : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('S')); - Res : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('R')); - - begin - -- Strm : 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))); - - -- Allocate_Buffer (Strm); - - Append_To (Stms, - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (RTE (RE_Allocate_Buffer), Loc), - Parameter_Associations => New_List ( - New_Occurrence_Of (Strm, 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 ( - New_Occurrence_Of (Any_Parameter, Loc), - New_Occurrence_Of (Strm, Loc)))); - - -- declare - -- Res : constant T := T'Input (Strm); - -- begin - -- Release_Buffer (Strm); - -- return Res; - -- end; - - Append_To (Stms, Make_Block_Statement (Loc, - Declarations => New_List ( - Make_Object_Declaration (Loc, - Defining_Identifier => Res, - Constant_Present => True, - Object_Definition => New_Occurrence_Of (Typ, Loc), - Expression => - 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))))), - - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List ( - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (RTE (RE_Release_Buffer), Loc), - Parameter_Associations => - New_List (New_Occurrence_Of (Strm, Loc))), - Make_Simple_Return_Statement (Loc, - Expression => New_Occurrence_Of (Res, Loc)))))); - - end; - 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 - (N : Node_Id; - Decls : List_Id) return Node_Id - is - Loc : constant Source_Ptr := Sloc (N); - - Typ : Entity_Id := Etype (N); - U_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); - - -- 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 Sloc (U_Type) <= Standard_Location then - U_Type := Base_Type (U_Type); - end if; - - if Present (Fnam) then - null; - - 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 = Etype (Standard_Short_Short_Integer) then - Lib_RE := RE_TA_SSI; - - elsif U_Type = Etype (Standard_Short_Integer) then - Lib_RE := RE_TA_SI; - - elsif U_Type = Etype (Standard_Integer) then - Lib_RE := RE_TA_I; - - elsif U_Type = Etype (Standard_Long_Integer) then - Lib_RE := RE_TA_LI; - - elsif U_Type = Etype (Standard_Long_Long_Integer) then - Lib_RE := RE_TA_LLI; - - -- Unsigned integer types - - elsif U_Type = RTE (RE_Short_Short_Unsigned) then - Lib_RE := RE_TA_SSU; - - elsif U_Type = RTE (RE_Short_Unsigned) then - Lib_RE := RE_TA_SU; - - elsif U_Type = RTE (RE_Unsigned) then - Lib_RE := RE_TA_U; - - elsif U_Type = RTE (RE_Long_Unsigned) then - Lib_RE := RE_TA_LU; - - elsif U_Type = RTE (RE_Long_Long_Unsigned) then - Lib_RE := RE_TA_LLU; - - elsif U_Type = Standard_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; - - return - Make_Function_Call (Loc, - Name => New_Occurrence_Of (Fnam, Loc), - Parameter_Associations => - New_List (Unchecked_Convert_To (U_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 : constant Entity_Id := - Make_Defining_Identifier (Loc, Name_E); - - Any : constant Entity_Id := - Make_Defining_Identifier (Loc, Name_A); - - Any_Decl : Node_Id; - Result_TC : Node_Id := Build_TypeCode_Call (Loc, Typ, Decls); - - Use_Opaque_Representation : Boolean; - -- When True, use stream attributes and represent type as an - -- opaque sequence of bytes. - - begin - if Is_Itype (Typ) then - Build_To_Any_Function - (Loc => Loc, - Typ => Etype (Typ), - Decl => Decl, - Fnam => Fnam); - return; - end if; - - 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 (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 (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 (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_Defining_Identifier (Loc, - New_Internal_Name ('V')); - - Struct_Any : constant Entity_Id := - Make_Defining_Identifier (Loc, - New_Internal_Name ('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 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 - (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 (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_Defining_Identifier (Loc, - Chars => New_Internal_Name ('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 Warnings (Off); - pragma Unreferenced (Counter); - pragma Warnings (On); - - Element_Any : Node_Id; - - begin - if Etype (Datum) = RTE (RE_Any) then - Element_Any := Datum; - else - Element_Any := Build_To_Any_Call (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, - Indices => 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 ( - 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 ( - 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_Defining_Identifier (Loc, - Chars => New_Internal_Name ('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: - -- Allocate_Buffer (Strm); - - Append_To (Stms, - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (RTE (RE_Allocate_Buffer), Loc), - Parameter_Associations => New_List ( - New_Occurrence_Of (Strm, 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; - - if No (Fnam) then - if Sloc (U_Type) <= Standard_Location then - - -- Do not try to build alias typecodes for subtypes from - -- Standard. - - U_Type := Base_Type (U_Type); - end if; - - 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 = Etype (Standard_Short_Short_Integer) then - Lib_RE := RE_TC_SSI; - - elsif U_Type = Etype (Standard_Short_Integer) then - Lib_RE := RE_TC_SI; - - elsif U_Type = Etype (Standard_Integer) then - Lib_RE := RE_TC_I; - - elsif U_Type = Etype (Standard_Long_Integer) then - Lib_RE := RE_TC_LI; - - elsif U_Type = Etype (Standard_Long_Long_Integer) then - Lib_RE := RE_TC_LLI; - - -- Unsigned integer types - - elsif U_Type = RTE (RE_Short_Short_Unsigned) then - Lib_RE := RE_TC_SSU; - - elsif U_Type = RTE (RE_Short_Unsigned) then - Lib_RE := RE_TC_SU; - - elsif U_Type = RTE (RE_Unsigned) then - Lib_RE := RE_TC_U; - - elsif U_Type = RTE (RE_Long_Unsigned) then - Lib_RE := RE_TC_LU; - - elsif U_Type = RTE (RE_Long_Long_Unsigned) then - Lib_RE := RE_TC_LLU; - - elsif U_Type = Standard_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_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_LI), 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 Warnings (Off); - pragma Unreferenced (Any, Counter, Rec); - pragma Warnings (On); - - 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 - - declare - Discriminant_Type : constant Entity_Id := - Etype (Name (Field)); - - Is_Enum : constant Boolean := - Is_Enumeration_Type (Discriminant_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; - - 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; - - 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, Discriminant_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 := New_Occurrence_Of ( - Get_Enum_Lit_From_Pos ( - Discriminant_Type, J, Loc), Loc); - else - Expr := - Make_Integer_Literal (Loc, J); - end if; - Append_To (Union_TC_Params, - Build_To_Any_Call (Expr, Decls)); - - Add_Params_For_Variant_Components; - J := J + Uint_1; - end loop; - end; - - when N_Others_Choice => - - -- This variant possess a default choice. - -- We must therefore set the default - -- parameter to the current choice index. The - -- default parameter is by construction the - -- fourth in the Union_TC_Params list. - - declare - Default_Node : constant Node_Id := - Pick (Union_TC_Params, 4); - - New_Default_Node : constant Node_Id := - Make_Function_Call (Loc, - Name => - New_Occurrence_Of - (RTE (RE_TA_LI), Loc), - Parameter_Associations => - New_List ( - Make_Integer_Literal - (Loc, Choice_Index))); - begin - Insert_Before ( - Default_Node, - New_Default_Node); - - Remove (Default_Node); - end; - - -- Add a placeholder member label - -- for the default case. - -- It must be of the discriminant type. - - declare - Exp : constant Node_Id := - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of - (Discriminant_Type, Loc), - Attribute_Name => Name_First); - begin - Set_Etype (Exp, Discriminant_Type); - Append_To (Union_TC_Params, - Build_To_Any_Call (Exp, Decls)); - end; - - Add_Params_For_Variant_Components; - - when others => - - -- Case of an explicit choice - - declare - Exp : constant Node_Id := - New_Copy_Tree (Choice); - begin - Append_To (Union_TC_Params, - Build_To_Any_Call (Exp, Decls)); - end; - - Add_Params_For_Variant_Components; - end case; - - Next (Choice); - Choice_Index := Choice_Index + 1; - end loop; - - Next_Non_Pragma (Variant); - end loop; - end; - end if; - end TC_Rec_Add_Process_Element; - - Type_Name_Str : String_Id; - Type_Repo_Id_Str : String_Id; - - begin - if Is_Itype (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 ( - OK_Convert_To (RTE (RE_Long_Unsigned), - 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 (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 ( - OK_Convert_To (RTE (RE_Long_Unsigned), - Make_Integer_Literal (Loc, 0)), - Decls), - Build_To_Any_Call (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 - if Is_Unsigned_Type (Typ) then - if P_Size <= Standard_Short_Short_Integer_Size then - return RTE (RE_Short_Short_Unsigned); - - elsif P_Size <= Standard_Short_Integer_Size then - return RTE (RE_Short_Unsigned); - - elsif P_Size <= Standard_Integer_Size then - return RTE (RE_Unsigned); - - elsif P_Size <= Standard_Long_Integer_Size then - return RTE (RE_Long_Unsigned); - - else - return RTE (RE_Long_Long_Unsigned); - end if; - - elsif Is_Integer_Type (Typ) then - if P_Size <= Standard_Short_Short_Integer_Size then - return Standard_Short_Short_Integer; - - elsif P_Size <= Standard_Short_Integer_Size then - return Standard_Short_Integer; - - elsif P_Size <= Standard_Integer_Size then - return Standard_Integer; - - elsif P_Size <= Standard_Long_Integer_Size then - return Standard_Long_Integer; - - else - return Standard_Long_Long_Integer; - 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), - Indices); - 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 (Indices, - 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_Long_Unsigned), 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_Long_Unsigned)); - - 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, we use a 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 not Is_Tagged_Type (Typ) then - Serial := Increment_Serial_Number; - end if; - - -- Use prefixed underscore to avoid potential clash with used - -- 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; - - 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_Defining_Identifier (Loc, New_Internal_Name ('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_Build_Stub_Type -- - ------------------------------ - - procedure Specific_Build_Stub_Type - (RACW_Type : Entity_Id; - Stub_Type : Entity_Id; - Stub_Type_Decl : out Node_Id; - RPC_Receiver_Decl : out Node_Id) - is - begin - case Get_PCS_Name is - when Name_PolyORB_DSA => - PolyORB_Support.Build_Stub_Type ( - RACW_Type, Stub_Type, - Stub_Type_Decl, RPC_Receiver_Decl); - - when others => - GARLIC_Support.Build_Stub_Type ( - RACW_Type, Stub_Type, - Stub_Type_Decl, RPC_Receiver_Decl); - end case; - end Specific_Build_Stub_Type; - - 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; |