| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT COMPILER COMPONENTS -- |
| -- -- |
| -- E X P_ D I S T -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- |
| -- -- |
| -- GNAT is free software; you can redistribute it and/or modify it under -- |
| -- terms of the GNU General Public License as published by the Free Soft- -- |
| -- ware Foundation; either version 3, or (at your option) any later ver- -- |
| -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- |
| -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- |
| -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- |
| -- for more details. You should have received a copy of the GNU General -- |
| -- Public License distributed with GNAT; see file COPYING3. If not, go to -- |
| -- http://www.gnu.org/licenses for a complete copy of the license. -- |
| -- -- |
| -- GNAT was originally developed by the GNAT team at New York University. -- |
| -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
| -- -- |
| ------------------------------------------------------------------------------ |
| |
| with Atree; use Atree; |
| with Einfo; use Einfo; |
| with Elists; use Elists; |
| with Exp_Atag; use Exp_Atag; |
| with Exp_Disp; use Exp_Disp; |
| with Exp_Strm; use Exp_Strm; |
| with Exp_Tss; use Exp_Tss; |
| with Exp_Util; use Exp_Util; |
| with Lib; use Lib; |
| with Nlists; use Nlists; |
| with Nmake; use Nmake; |
| with Opt; use Opt; |
| with Rtsfind; use Rtsfind; |
| with Sem; use Sem; |
| with Sem_Aux; use Sem_Aux; |
| with Sem_Cat; use Sem_Cat; |
| with Sem_Ch3; use Sem_Ch3; |
| with Sem_Ch8; use Sem_Ch8; |
| with Sem_Ch12; use Sem_Ch12; |
| with Sem_Dist; use Sem_Dist; |
| with Sem_Eval; use Sem_Eval; |
| with Sem_Util; use Sem_Util; |
| with Sinfo; use Sinfo; |
| with Stand; use Stand; |
| with Stringt; use Stringt; |
| with Tbuild; use Tbuild; |
| with Ttypes; use Ttypes; |
| with Uintp; use Uintp; |
| |
| with GNAT.HTable; use GNAT.HTable; |
| |
| package body Exp_Dist is |
| |
| -- The following model has been used to implement distributed objects: |
| -- given a designated type D and a RACW type R, then a record of the form: |
| |
| -- type Stub is tagged record |
| -- [...declaration similar to s-parint.ads RACW_Stub_Type...] |
| -- end record; |
| |
| -- is built. This type has two properties: |
| |
| -- 1) Since it has the same structure as RACW_Stub_Type, it can |
| -- be converted to and from this type to make it suitable for |
| -- System.Partition_Interface.Get_Unique_Remote_Pointer in order |
| -- to avoid memory leaks when the same remote object arrives on the |
| -- same partition through several paths; |
| |
| -- 2) It also has the same dispatching table as the designated type D, |
| -- and thus can be used as an object designated by a value of type |
| -- R on any partition other than the one on which the object has |
| -- been created, since only dispatching calls will be performed and |
| -- the fields themselves will not be used. We call Derive_Subprograms |
| -- to fake half a derivation to ensure that the subprograms do have |
| -- the same dispatching table. |
| |
| First_RCI_Subprogram_Id : constant := 2; |
| -- RCI subprograms are numbered starting at 2. The RCI receiver for |
| -- an RCI package can thus identify calls received through remote |
| -- access-to-subprogram dereferences by the fact that they have a |
| -- (primitive) subprogram id of 0, and 1 is used for the internal RAS |
| -- information lookup operation. (This is for the Garlic code generation, |
| -- where subprograms are identified by numbers; in the PolyORB version, |
| -- they are identified by name, with a numeric suffix for homonyms.) |
| |
| type Hash_Index is range 0 .. 50; |
| |
| ----------------------- |
| -- Local subprograms -- |
| ----------------------- |
| |
| function Hash (F : Entity_Id) return Hash_Index; |
| -- DSA expansion associates stubs to distributed object types using a hash |
| -- table on entity ids. |
| |
| function Hash (F : Name_Id) return Hash_Index; |
| -- The generation of subprogram identifiers requires an overload counter |
| -- to be associated with each remote subprogram name. These counters are |
| -- maintained in a hash table on name ids. |
| |
| type Subprogram_Identifiers is record |
| Str_Identifier : String_Id; |
| Int_Identifier : Int; |
| end record; |
| |
| package Subprogram_Identifier_Table is |
| new Simple_HTable (Header_Num => Hash_Index, |
| Element => Subprogram_Identifiers, |
| No_Element => (No_String, 0), |
| Key => Entity_Id, |
| Hash => Hash, |
| Equal => "="); |
| -- Mapping between a remote subprogram and the corresponding subprogram |
| -- identifiers. |
| |
| package Overload_Counter_Table is |
| new Simple_HTable (Header_Num => Hash_Index, |
| Element => Int, |
| No_Element => 0, |
| Key => Name_Id, |
| Hash => Hash, |
| Equal => "="); |
| -- Mapping between a subprogram name and an integer that counts the number |
| -- of defining subprogram names with that Name_Id encountered so far in a |
| -- given context (an interface). |
| |
| function Get_Subprogram_Ids (Def : Entity_Id) return Subprogram_Identifiers; |
| function Get_Subprogram_Id (Def : Entity_Id) return String_Id; |
| function Get_Subprogram_Id (Def : Entity_Id) return Int; |
| -- Given a subprogram defined in a RCI package, get its distribution |
| -- subprogram identifiers (the distribution identifiers are a unique |
| -- subprogram number, and the non-qualified subprogram name, in the |
| -- casing used for the subprogram declaration; if the name is overloaded, |
| -- a double underscore and a serial number are appended. |
| -- |
| -- The integer identifier is used to perform remote calls with GARLIC; |
| -- the string identifier is used in the case of PolyORB. |
| -- |
| -- Although the PolyORB DSA receiving stubs will make a caseless comparison |
| -- when receiving a call, the calling stubs will create requests with the |
| -- exact casing of the defining unit name of the called subprogram, so as |
| -- to allow calls to subprograms on distributed nodes that do distinguish |
| -- between casings. |
| -- |
| -- NOTE: Another design would be to allow a representation clause on |
| -- subprogram specs: for Subp'Distribution_Identifier use "fooBar"; |
| |
| pragma Warnings (Off, Get_Subprogram_Id); |
| -- One homonym only is unreferenced (specific to the GARLIC version) |
| |
| procedure Add_RAS_Dereference_TSS (N : Node_Id); |
| -- Add a subprogram body for RAS Dereference TSS |
| |
| procedure Add_RAS_Proxy_And_Analyze |
| (Decls : List_Id; |
| Vis_Decl : Node_Id; |
| All_Calls_Remote_E : Entity_Id; |
| Proxy_Object_Addr : out Entity_Id); |
| -- Add the proxy type required, on the receiving (server) side, to handle |
| -- calls to the subprogram declared by Vis_Decl through a remote access |
| -- to subprogram type. All_Calls_Remote_E must be Standard_True if a pragma |
| -- All_Calls_Remote applies, Standard_False otherwise. The new proxy type |
| -- is appended to Decls. Proxy_Object_Addr is a constant of type |
| -- System.Address that designates an instance of the proxy object. |
| |
| function Build_Remote_Subprogram_Proxy_Type |
| (Loc : Source_Ptr; |
| ACR_Expression : Node_Id) return Node_Id; |
| -- Build and return a tagged record type definition for an RCI subprogram |
| -- proxy type. ACR_Expression is used as the initialization value for the |
| -- All_Calls_Remote component. |
| |
| function Build_Get_Unique_RP_Call |
| (Loc : Source_Ptr; |
| Pointer : Entity_Id; |
| Stub_Type : Entity_Id) return List_Id; |
| -- Build a call to Get_Unique_Remote_Pointer (Pointer), followed by a |
| -- tag fixup (Get_Unique_Remote_Pointer may have changed Pointer'Tag to |
| -- RACW_Stub_Type'Tag, while the desired tag is that of Stub_Type). |
| |
| function Build_Stub_Tag |
| (Loc : Source_Ptr; |
| RACW_Type : Entity_Id) return Node_Id; |
| -- Return an expression denoting the tag of the stub type associated with |
| -- RACW_Type. |
| |
| function Build_Subprogram_Calling_Stubs |
| (Vis_Decl : Node_Id; |
| Subp_Id : Node_Id; |
| Asynchronous : Boolean; |
| Dynamically_Asynchronous : Boolean := False; |
| Stub_Type : Entity_Id := Empty; |
| RACW_Type : Entity_Id := Empty; |
| Locator : Entity_Id := Empty; |
| New_Name : Name_Id := No_Name) return Node_Id; |
| -- Build the calling stub for a given subprogram with the subprogram ID |
| -- being Subp_Id. If Stub_Type is given, then the "addr" field of |
| -- parameters of this type will be marshalled instead of the object itself. |
| -- It will then be converted into Stub_Type before performing the real |
| -- call. If Dynamically_Asynchronous is True, then it will be computed at |
| -- run time whether the call is asynchronous or not. Otherwise, the value |
| -- of the formal Asynchronous will be used. If Locator is not Empty, it |
| -- will be used instead of RCI_Cache. If New_Name is given, then it will |
| -- be used instead of the original name. |
| |
| function Build_RPC_Receiver_Specification |
| (RPC_Receiver : Entity_Id; |
| Request_Parameter : Entity_Id) return Node_Id; |
| -- Make a subprogram specification for an RPC receiver, with the given |
| -- defining unit name and formal parameter. |
| |
| function Build_Ordered_Parameters_List (Spec : Node_Id) return List_Id; |
| -- Return an ordered parameter list: unconstrained parameters are put |
| -- at the beginning of the list and constrained ones are put after. If |
| -- there are no parameters, an empty list is returned. Special case: |
| -- the controlling formal of the equivalent RACW operation for a RAS |
| -- type is always left in first position. |
| |
| function Transmit_As_Unconstrained (Typ : Entity_Id) return Boolean; |
| -- True when Typ is an unconstrained type, or a null-excluding access type. |
| -- In either case, this means stubs cannot contain a default-initialized |
| -- object declaration of such type. |
| |
| procedure Add_Calling_Stubs_To_Declarations (Pkg_Spec : Node_Id); |
| -- Add calling stubs to the declarative part |
| |
| function Could_Be_Asynchronous (Spec : Node_Id) return Boolean; |
| -- Return True if nothing prevents the program whose specification is |
| -- given to be asynchronous (i.e. no [IN] OUT parameters). |
| |
| function Pack_Entity_Into_Stream_Access |
| (Loc : Source_Ptr; |
| Stream : Node_Id; |
| Object : Entity_Id; |
| Etyp : Entity_Id := Empty) return Node_Id; |
| -- Pack Object (of type Etyp) into Stream. If Etyp is not given, |
| -- then Etype (Object) will be used if present. If the type is |
| -- constrained, then 'Write will be used to output the object, |
| -- If the type is unconstrained, 'Output will be used. |
| |
| function Pack_Node_Into_Stream |
| (Loc : Source_Ptr; |
| Stream : Entity_Id; |
| Object : Node_Id; |
| Etyp : Entity_Id) return Node_Id; |
| -- Similar to above, with an arbitrary node instead of an entity |
| |
| function Pack_Node_Into_Stream_Access |
| (Loc : Source_Ptr; |
| Stream : Node_Id; |
| Object : Node_Id; |
| Etyp : Entity_Id) return Node_Id; |
| -- Similar to above, with Stream instead of Stream'Access |
| |
| function Make_Selected_Component |
| (Loc : Source_Ptr; |
| Prefix : Entity_Id; |
| Selector_Name : Name_Id) return Node_Id; |
| -- Return a selected_component whose prefix denotes the given entity, and |
| -- with the given Selector_Name. |
| |
| function Scope_Of_Spec (Spec : Node_Id) return Entity_Id; |
| -- Return the scope represented by a given spec |
| |
| procedure Set_Renaming_TSS |
| (Typ : Entity_Id; |
| Nam : Entity_Id; |
| TSS_Nam : TSS_Name_Type); |
| -- Create a renaming declaration of subprogram Nam, and register it as a |
| -- TSS for Typ with name TSS_Nam. |
| |
| function Need_Extra_Constrained (Parameter : Node_Id) return Boolean; |
| -- Return True if the current parameter needs an extra formal to reflect |
| -- its constrained status. |
| |
| function Is_RACW_Controlling_Formal |
| (Parameter : Node_Id; |
| Stub_Type : Entity_Id) return Boolean; |
| -- Return True if the current parameter is a controlling formal argument |
| -- of type Stub_Type or access to Stub_Type. |
| |
| procedure Declare_Create_NVList |
| (Loc : Source_Ptr; |
| NVList : Entity_Id; |
| Decls : List_Id; |
| Stmts : List_Id); |
| -- Append the declaration of NVList to Decls, and its |
| -- initialization to Stmts. |
| |
| function Add_Parameter_To_NVList |
| (Loc : Source_Ptr; |
| NVList : Entity_Id; |
| Parameter : Entity_Id; |
| Constrained : Boolean; |
| RACW_Ctrl : Boolean := False; |
| Any : Entity_Id) return Node_Id; |
| -- Return a call to Add_Item to add the Any corresponding to the designated |
| -- formal Parameter (with the indicated Constrained status) to NVList. |
| -- RACW_Ctrl must be set to True for controlling formals of distributed |
| -- object primitive operations. |
| |
| -------------------- |
| -- Stub_Structure -- |
| -------------------- |
| |
| -- This record describes various tree fragments associated with the |
| -- generation of RACW calling stubs. One such record exists for every |
| -- distributed object type, i.e. each tagged type that is the designated |
| -- type of one or more RACW type. |
| |
| type Stub_Structure is record |
| Stub_Type : Entity_Id; |
| -- Stub type: this type has the same primitive operations as the |
| -- designated types, but the provided bodies for these operations |
| -- a remote call to an actual target object potentially located on |
| -- another partition; each value of the stub type encapsulates a |
| -- reference to a remote object. |
| |
| Stub_Type_Access : Entity_Id; |
| -- A local access type designating the stub type (this is not an RACW |
| -- type). |
| |
| RPC_Receiver_Decl : Node_Id; |
| -- Declaration for the RPC receiver entity associated with the |
| -- designated type. As an exception, in the case of GARLIC, for an RACW |
| -- that implements a RAS, no object RPC receiver is generated. Instead, |
| -- RPC_Receiver_Decl is the declaration after which the RPC receiver |
| -- would have been inserted. |
| |
| Body_Decls : List_Id; |
| -- List of subprogram bodies to be included in generated code: bodies |
| -- for the RACW's stream attributes, and for the primitive operations |
| -- of the stub type. |
| |
| RACW_Type : Entity_Id; |
| -- One of the RACW types designating this distributed object type |
| -- (they are all interchangeable; we use any one of them in order to |
| -- avoid having to create various anonymous access types). |
| |
| end record; |
| |
| Empty_Stub_Structure : constant Stub_Structure := |
| (Empty, Empty, Empty, No_List, Empty); |
| |
| package Stubs_Table is |
| new Simple_HTable (Header_Num => Hash_Index, |
| Element => Stub_Structure, |
| No_Element => Empty_Stub_Structure, |
| Key => Entity_Id, |
| Hash => Hash, |
| Equal => "="); |
| -- Mapping between a RACW designated type and its stub type |
| |
| package Asynchronous_Flags_Table is |
| new Simple_HTable (Header_Num => Hash_Index, |
| Element => Entity_Id, |
| No_Element => Empty, |
| Key => Entity_Id, |
| Hash => Hash, |
| Equal => "="); |
| -- Mapping between a RACW type and a constant having the value True |
| -- if the RACW is asynchronous and False otherwise. |
| |
| package RCI_Locator_Table is |
| new Simple_HTable (Header_Num => Hash_Index, |
| Element => Entity_Id, |
| No_Element => Empty, |
| Key => Entity_Id, |
| Hash => Hash, |
| Equal => "="); |
| -- Mapping between a RCI package on which All_Calls_Remote applies and |
| -- the generic instantiation of RCI_Locator for this package. |
| |
| package RCI_Calling_Stubs_Table is |
| new Simple_HTable (Header_Num => Hash_Index, |
| Element => Entity_Id, |
| No_Element => Empty, |
| Key => Entity_Id, |
| Hash => Hash, |
| Equal => "="); |
| -- Mapping between a RCI subprogram and the corresponding calling stubs |
| |
| function Get_Stub_Elements (RACW_Type : Entity_Id) return Stub_Structure; |
| -- Return the stub information associated with the given RACW type |
| |
| procedure Add_Stub_Type |
| (Designated_Type : Entity_Id; |
| RACW_Type : Entity_Id; |
| Decls : List_Id; |
| Stub_Type : out Entity_Id; |
| Stub_Type_Access : out Entity_Id; |
| RPC_Receiver_Decl : out Node_Id; |
| Body_Decls : out List_Id; |
| Existing : out Boolean); |
| -- Add the declaration of the stub type, the access to stub type and the |
| -- object RPC receiver at the end of Decls. If these already exist, |
| -- then nothing is added in the tree but the right values are returned |
| -- anyhow and Existing is set to True. |
| |
| function Get_And_Reset_RACW_Bodies (RACW_Type : Entity_Id) return List_Id; |
| -- Retrieve the Body_Decls list associated to RACW_Type in the stub |
| -- structure table, reset it to No_List, and return the previous value. |
| |
| procedure Add_RACW_Asynchronous_Flag |
| (Declarations : List_Id; |
| RACW_Type : Entity_Id); |
| -- Declare a boolean constant associated with RACW_Type whose value |
| -- indicates at run time whether a pragma Asynchronous applies to it. |
| |
| procedure Assign_Subprogram_Identifier |
| (Def : Entity_Id; |
| Spn : Int; |
| Id : out String_Id); |
| -- Determine the distribution subprogram identifier to |
| -- be used for remote subprogram Def, return it in Id and |
| -- store it in a hash table for later retrieval by |
| -- Get_Subprogram_Id. Spn is the subprogram number. |
| |
| function RCI_Package_Locator |
| (Loc : Source_Ptr; |
| Package_Spec : Node_Id) return Node_Id; |
| -- Instantiate the generic package RCI_Locator in order to locate the |
| -- RCI package whose spec is given as argument. |
| |
| function Make_Tag_Check (Loc : Source_Ptr; N : Node_Id) return Node_Id; |
| -- Surround a node N by a tag check, as in: |
| -- begin |
| -- <N>; |
| -- exception |
| -- when E : Ada.Tags.Tag_Error => |
| -- Raise_Exception (Program_Error'Identity, |
| -- Exception_Message (E)); |
| -- end; |
| |
| function Input_With_Tag_Check |
| (Loc : Source_Ptr; |
| Var_Type : Entity_Id; |
| Stream : Node_Id) return Node_Id; |
| -- Return a function with the following form: |
| -- function R return Var_Type is |
| -- begin |
| -- return Var_Type'Input (S); |
| -- exception |
| -- when E : Ada.Tags.Tag_Error => |
| -- Raise_Exception (Program_Error'Identity, |
| -- Exception_Message (E)); |
| -- end R; |
| |
| procedure Build_Actual_Object_Declaration |
| (Object : Entity_Id; |
| Etyp : Entity_Id; |
| Variable : Boolean; |
| Expr : Node_Id; |
| Decls : List_Id); |
| -- Build the declaration of an object with the given defining identifier, |
| -- initialized with Expr if provided, to serve as actual parameter in a |
| -- server stub. If Variable is true, the declared object will be a variable |
| -- (case of an out or in out formal), else it will be a constant. Object's |
| -- Ekind is set accordingly. The declaration, as well as any other |
| -- declarations it requires, are appended to Decls. |
| |
| -------------------------------------------- |
| -- Hooks for PCS-specific code generation -- |
| -------------------------------------------- |
| |
| -- Part of the code generation circuitry for distribution needs to be |
| -- tailored for each implementation of the PCS. For each routine that |
| -- needs to be specialized, a Specific_<routine> wrapper is created, |
| -- which calls the corresponding <routine> in package |
| -- <pcs_implementation>_Support. |
| |
| procedure Specific_Add_RACW_Features |
| (RACW_Type : Entity_Id; |
| Desig : Entity_Id; |
| Stub_Type : Entity_Id; |
| Stub_Type_Access : Entity_Id; |
| RPC_Receiver_Decl : Node_Id; |
| Body_Decls : List_Id); |
| -- Add declaration for TSSs for a given RACW type. The declarations are |
| -- added just after the declaration of the RACW type itself. If the RACW |
| -- appears in the main unit, Body_Decls is a list of declarations to which |
| -- the bodies are appended. Else Body_Decls is No_List. |
| -- PCS-specific ancillary subprogram for Add_RACW_Features. |
| |
| procedure Specific_Add_RAST_Features |
| (Vis_Decl : Node_Id; |
| RAS_Type : Entity_Id); |
| -- Add declaration for TSSs for a given RAS type. PCS-specific ancillary |
| -- subprogram for Add_RAST_Features. |
| |
| -- An RPC_Target record is used during construction of calling stubs |
| -- to pass PCS-specific tree fragments corresponding to the information |
| -- necessary to locate the target of a remote subprogram call. |
| |
| type RPC_Target (PCS_Kind : PCS_Names) is record |
| case PCS_Kind is |
| when Name_PolyORB_DSA => |
| Object : Node_Id; |
| -- An expression whose value is a PolyORB reference to the target |
| -- object. |
| |
| when others => |
| Partition : Entity_Id; |
| -- A variable containing the Partition_ID of the target partition |
| |
| RPC_Receiver : Node_Id; |
| -- An expression whose value is the address of the target RPC |
| -- receiver. |
| end case; |
| end record; |
| |
| procedure Specific_Build_General_Calling_Stubs |
| (Decls : List_Id; |
| Statements : List_Id; |
| Target : RPC_Target; |
| Subprogram_Id : Node_Id; |
| Asynchronous : Node_Id := Empty; |
| Is_Known_Asynchronous : Boolean := False; |
| Is_Known_Non_Asynchronous : Boolean := False; |
| Is_Function : Boolean; |
| Spec : Node_Id; |
| Stub_Type : Entity_Id := Empty; |
| RACW_Type : Entity_Id := Empty; |
| Nod : Node_Id); |
| -- Build calling stubs for general purpose. The parameters are: |
| -- Decls : A place to put declarations |
| -- Statements : A place to put statements |
| -- Target : PCS-specific target information (see details in |
| -- RPC_Target declaration). |
| -- Subprogram_Id : A node containing the subprogram ID |
| -- Asynchronous : True if an APC must be made instead of an RPC. |
| -- The value needs not be supplied if one of the |
| -- Is_Known_... is True. |
| -- Is_Known_Async... : True if we know that this is asynchronous |
| -- Is_Known_Non_A... : True if we know that this is not asynchronous |
| -- Spec : Node with a Parameter_Specifications and a |
| -- Result_Definition if applicable |
| -- Stub_Type : For case of RACW stubs, parameters of type access |
| -- to Stub_Type will be marshalled using the address |
| -- address of the object (the addr field) rather |
| -- than using the 'Write on the stub itself |
| -- Nod : Used to provide sloc for generated code |
| |
| function Specific_Build_Stub_Target |
| (Loc : Source_Ptr; |
| Decls : List_Id; |
| RCI_Locator : Entity_Id; |
| Controlling_Parameter : Entity_Id) return RPC_Target; |
| -- Build call target information nodes for use within calling stubs. In the |
| -- RCI case, RCI_Locator is the entity for the instance of RCI_Locator. If |
| -- for an RACW, Controlling_Parameter is the entity for the controlling |
| -- formal parameter used to determine the location of the target of the |
| -- call. Decls provides a location where variable declarations can be |
| -- appended to construct the necessary values. |
| |
| function Specific_RPC_Receiver_Decl |
| (RACW_Type : Entity_Id) return Node_Id; |
| -- Build the RPC receiver, for RACW, if applicable, else return Empty |
| |
| procedure Specific_Build_RPC_Receiver_Body |
| (RPC_Receiver : Entity_Id; |
| Request : out Entity_Id; |
| Subp_Id : out Entity_Id; |
| Subp_Index : out Entity_Id; |
| Stmts : out List_Id; |
| Decl : out Node_Id); |
| -- Make a subprogram body for an RPC receiver, with the given |
| -- defining unit name. On return: |
| -- - Subp_Id is the subprogram identifier from the PCS. |
| -- - Subp_Index is the index in the list of subprograms |
| -- used for dispatching (a variable of type Subprogram_Id). |
| -- - Stmts is the place where the request dispatching |
| -- statements can occur, |
| -- - Decl is the subprogram body declaration. |
| |
| function Specific_Build_Subprogram_Receiving_Stubs |
| (Vis_Decl : Node_Id; |
| Asynchronous : Boolean; |
| Dynamically_Asynchronous : Boolean := False; |
| Stub_Type : Entity_Id := Empty; |
| RACW_Type : Entity_Id := Empty; |
| Parent_Primitive : Entity_Id := Empty) return Node_Id; |
| -- Build the receiving stub for a given subprogram. The subprogram |
| -- declaration is also built by this procedure, and the value returned |
| -- is a N_Subprogram_Body. If a parameter of type access to Stub_Type is |
| -- found in the specification, then its address is read from the stream |
| -- instead of the object itself and converted into an access to |
| -- class-wide type before doing the real call using any of the RACW type |
| -- pointing on the designated type. |
| |
| procedure Specific_Add_Obj_RPC_Receiver_Completion |
| (Loc : Source_Ptr; |
| Decls : List_Id; |
| RPC_Receiver : Entity_Id; |
| Stub_Elements : Stub_Structure); |
| -- Add the necessary code to Decls after the completion of generation |
| -- of the RACW RPC receiver described by Stub_Elements. |
| |
| procedure Specific_Add_Receiving_Stubs_To_Declarations |
| (Pkg_Spec : Node_Id; |
| Decls : List_Id; |
| Stmts : List_Id); |
| -- Add receiving stubs to the declarative part of an RCI unit |
| |
| -------------------- |
| -- GARLIC_Support -- |
| -------------------- |
| |
| package GARLIC_Support is |
| |
| -- Support for generating DSA code that uses the GARLIC PCS |
| |
| -- The subprograms below provide the GARLIC versions of the |
| -- corresponding Specific_<subprogram> routine declared above. |
| |
| procedure Add_RACW_Features |
| (RACW_Type : Entity_Id; |
| Stub_Type : Entity_Id; |
| Stub_Type_Access : Entity_Id; |
| RPC_Receiver_Decl : Node_Id; |
| Body_Decls : List_Id); |
| |
| procedure Add_RAST_Features |
| (Vis_Decl : Node_Id; |
| RAS_Type : Entity_Id); |
| |
| procedure Build_General_Calling_Stubs |
| (Decls : List_Id; |
| Statements : List_Id; |
| Target_Partition : Entity_Id; -- From RPC_Target |
| Target_RPC_Receiver : Node_Id; -- From RPC_Target |
| Subprogram_Id : Node_Id; |
| Asynchronous : Node_Id := Empty; |
| Is_Known_Asynchronous : Boolean := False; |
| Is_Known_Non_Asynchronous : Boolean := False; |
| Is_Function : Boolean; |
| Spec : Node_Id; |
| Stub_Type : Entity_Id := Empty; |
| RACW_Type : Entity_Id := Empty; |
| Nod : Node_Id); |
| |
| function Build_Stub_Target |
| (Loc : Source_Ptr; |
| Decls : List_Id; |
| RCI_Locator : Entity_Id; |
| Controlling_Parameter : Entity_Id) return RPC_Target; |
| |
| function RPC_Receiver_Decl (RACW_Type : Entity_Id) return Node_Id; |
| |
| function Build_Subprogram_Receiving_Stubs |
| (Vis_Decl : Node_Id; |
| Asynchronous : Boolean; |
| Dynamically_Asynchronous : Boolean := False; |
| Stub_Type : Entity_Id := Empty; |
| RACW_Type : Entity_Id := Empty; |
| Parent_Primitive : Entity_Id := Empty) return Node_Id; |
| |
| procedure Add_Obj_RPC_Receiver_Completion |
| (Loc : Source_Ptr; |
| Decls : List_Id; |
| RPC_Receiver : Entity_Id; |
| Stub_Elements : Stub_Structure); |
| |
| procedure Add_Receiving_Stubs_To_Declarations |
| (Pkg_Spec : Node_Id; |
| Decls : List_Id; |
| Stmts : List_Id); |
| |
| procedure Build_RPC_Receiver_Body |
| (RPC_Receiver : Entity_Id; |
| Request : out Entity_Id; |
| Subp_Id : out Entity_Id; |
| Subp_Index : out Entity_Id; |
| Stmts : out List_Id; |
| Decl : out Node_Id); |
| |
| end GARLIC_Support; |
| |
| --------------------- |
| -- PolyORB_Support -- |
| --------------------- |
| |
| package PolyORB_Support is |
| |
| -- Support for generating DSA code that uses the PolyORB PCS |
| |
| -- The subprograms below provide the PolyORB versions of the |
| -- corresponding Specific_<subprogram> routine declared above. |
| |
| procedure Add_RACW_Features |
| (RACW_Type : Entity_Id; |
| Desig : Entity_Id; |
| Stub_Type : Entity_Id; |
| Stub_Type_Access : Entity_Id; |
| RPC_Receiver_Decl : Node_Id; |
| Body_Decls : List_Id); |
| |
| procedure Add_RAST_Features |
| (Vis_Decl : Node_Id; |
| RAS_Type : Entity_Id); |
| |
| procedure Build_General_Calling_Stubs |
| (Decls : List_Id; |
| Statements : List_Id; |
| Target_Object : Node_Id; -- From RPC_Target |
| Subprogram_Id : Node_Id; |
| Asynchronous : Node_Id := Empty; |
| Is_Known_Asynchronous : Boolean := False; |
| Is_Known_Non_Asynchronous : Boolean := False; |
| Is_Function : Boolean; |
| Spec : Node_Id; |
| Stub_Type : Entity_Id := Empty; |
| RACW_Type : Entity_Id := Empty; |
| Nod : Node_Id); |
| |
| function Build_Stub_Target |
| (Loc : Source_Ptr; |
| Decls : List_Id; |
| RCI_Locator : Entity_Id; |
| Controlling_Parameter : Entity_Id) return RPC_Target; |
| |
| function RPC_Receiver_Decl (RACW_Type : Entity_Id) return Node_Id; |
| |
| function Build_Subprogram_Receiving_Stubs |
| (Vis_Decl : Node_Id; |
| Asynchronous : Boolean; |
| Dynamically_Asynchronous : Boolean := False; |
| Stub_Type : Entity_Id := Empty; |
| RACW_Type : Entity_Id := Empty; |
| Parent_Primitive : Entity_Id := Empty) return Node_Id; |
| |
| procedure Add_Obj_RPC_Receiver_Completion |
| (Loc : Source_Ptr; |
| Decls : List_Id; |
| RPC_Receiver : Entity_Id; |
| Stub_Elements : Stub_Structure); |
| |
| procedure Add_Receiving_Stubs_To_Declarations |
| (Pkg_Spec : Node_Id; |
| Decls : List_Id; |
| Stmts : List_Id); |
| |
| procedure Build_RPC_Receiver_Body |
| (RPC_Receiver : Entity_Id; |
| Request : out Entity_Id; |
| Subp_Id : out Entity_Id; |
| Subp_Index : out Entity_Id; |
| Stmts : out List_Id; |
| Decl : out Node_Id); |
| |
| procedure Reserve_NamingContext_Methods; |
| -- Mark the method names for interface NamingContext as already used in |
| -- the overload table, so no clashes occur with user code (with the |
| -- PolyORB PCS, RCIs Implement The NamingContext interface to allow |
| -- their methods to be accessed as objects, for the implementation of |
| -- remote access-to-subprogram types). |
| |
| ------------- |
| -- Helpers -- |
| ------------- |
| |
| package Helpers is |
| |
| -- Routines to build distribution helper subprograms for user-defined |
| -- types. For implementation of the Distributed systems annex (DSA) |
| -- over the PolyORB generic middleware components, it is necessary to |
| -- generate several supporting subprograms for each application data |
| -- type used in inter-partition communication. These subprograms are: |
| |
| -- A Typecode function returning a high-level description of the |
| -- type's structure; |
| |
| -- Two conversion functions allowing conversion of values of the |
| -- type from and to the generic data containers used by PolyORB. |
| -- These generic containers are called 'Any' type values after the |
| -- CORBA terminology, and hence the conversion subprograms are |
| -- named To_Any and From_Any. |
| |
| function Build_From_Any_Call |
| (Typ : Entity_Id; |
| N : Node_Id; |
| Decls : List_Id) return Node_Id; |
| -- Build call to From_Any attribute function of type Typ with |
| -- expression N as actual parameter. Decls is the declarations list |
| -- for an appropriate enclosing scope of the point where the call |
| -- will be inserted; if the From_Any attribute for Typ needs to be |
| -- generated at this point, its declaration is appended to Decls. |
| |
| procedure Build_From_Any_Function |
| (Loc : Source_Ptr; |
| Typ : Entity_Id; |
| Decl : out Node_Id; |
| Fnam : out Entity_Id); |
| -- Build From_Any attribute function for Typ. Loc is the reference |
| -- location for generated nodes, Typ is the type for which the |
| -- conversion function is generated. On return, Decl and Fnam contain |
| -- the declaration and entity for the newly-created function. |
| |
| function Build_To_Any_Call |
| (Loc : Source_Ptr; |
| N : Node_Id; |
| Decls : List_Id; |
| Constrained : Boolean := False) return Node_Id; |
| -- Build call to To_Any attribute function with expression as actual |
| -- parameter. Loc is the reference location of generated nodes, |
| -- Decls is the declarations list for an appropriate enclosing scope |
| -- of the point where the call will be inserted; if the To_Any |
| -- attribute for the type of N needs to be generated at this point, |
| -- its declaration is appended to Decls. For the case of a limited |
| -- type, there is an additional parameter Constrained indicating |
| -- whether 'Write (when True) or 'Output (when False) is used. |
| |
| procedure Build_To_Any_Function |
| (Loc : Source_Ptr; |
| Typ : Entity_Id; |
| Decl : out Node_Id; |
| Fnam : out Entity_Id); |
| -- Build To_Any attribute function for Typ. Loc is the reference |
| -- location for generated nodes, Typ is the type for which the |
| -- conversion function is generated. On return, Decl and Fnam contain |
| -- the declaration and entity for the newly-created function. |
| |
| function Build_TypeCode_Call |
| (Loc : Source_Ptr; |
| Typ : Entity_Id; |
| Decls : List_Id) return Node_Id; |
| -- Build call to TypeCode attribute function for Typ. Decls is the |
| -- declarations list for an appropriate enclosing scope of the point |
| -- where the call will be inserted; if the To_Any attribute for Typ |
| -- needs to be generated at this point, its declaration is appended |
| -- to Decls. |
| |
| procedure Build_TypeCode_Function |
| (Loc : Source_Ptr; |
| Typ : Entity_Id; |
| Decl : out Node_Id; |
| Fnam : out Entity_Id); |
| -- Build TypeCode attribute function for Typ. Loc is the reference |
| -- location for generated nodes, Typ is the type for which the |
| -- typecode function is generated. On return, Decl and Fnam contain |
| -- the declaration and entity for the newly-created function. |
| |
| procedure Build_Name_And_Repository_Id |
| (E : Entity_Id; |
| Name_Str : out String_Id; |
| Repo_Id_Str : out String_Id); |
| -- In the PolyORB distribution model, each distributed object type |
| -- and each distributed operation has a globally unique identifier, |
| -- its Repository Id. This subprogram builds and returns two strings |
| -- for entity E (a distributed object type or operation): one |
| -- containing the name of E, the second containing its repository id. |
| |
| procedure Assign_Opaque_From_Any |
| (Loc : Source_Ptr; |
| Stms : List_Id; |
| Typ : Entity_Id; |
| N : Node_Id; |
| Target : Entity_Id; |
| Constrained : Boolean := False); |
| -- For a Target object of type Typ, which has opaque representation |
| -- as a sequence of octets determined by stream attributes (which |
| -- includes all limited types), append code to Stmts performing the |
| -- equivalent of: |
| -- Target := Typ'From_Any (N) |
| -- |
| -- or, if Target is Empty: |
| -- return Typ'From_Any (N) |
| -- |
| -- Constrained determines whether 'Input (when False) or 'Read |
| -- (when True) is used. |
| |
| end Helpers; |
| |
| end PolyORB_Support; |
| |
| -- The following PolyORB-specific subprograms are made visible to Exp_Attr: |
| |
| function Build_From_Any_Call |
| (Typ : Entity_Id; |
| N : Node_Id; |
| Decls : List_Id) return Node_Id |
| renames PolyORB_Support.Helpers.Build_From_Any_Call; |
| |
| function Build_To_Any_Call |
| (Loc : Source_Ptr; |
| N : Node_Id; |
| Decls : List_Id; |
| Constrained : Boolean := False) return Node_Id |
| renames PolyORB_Support.Helpers.Build_To_Any_Call; |
| |
| function Build_TypeCode_Call |
| (Loc : Source_Ptr; |
| Typ : Entity_Id; |
| Decls : List_Id) return Node_Id |
| renames PolyORB_Support.Helpers.Build_TypeCode_Call; |
| |
| ------------------------------------ |
| -- Local variables and structures -- |
| ------------------------------------ |
| |
| RCI_Cache : Node_Id; |
| -- Needs comments ??? |
| |
| Output_From_Constrained : constant array (Boolean) of Name_Id := |
| (False => Name_Output, |
| True => Name_Write); |
| -- The attribute to choose depending on the fact that the parameter |
| -- is constrained or not. There is no such thing as Input_From_Constrained |
| -- since this require separate mechanisms ('Input is a function while |
| -- 'Read is a procedure). |
| |
| generic |
| with procedure Process_Subprogram_Declaration (Decl : Node_Id); |
| -- Generate calling or receiving stub for this subprogram declaration |
| |
| procedure Build_Package_Stubs (Pkg_Spec : Node_Id); |
| -- Recursively visit the given RCI Package_Specification, calling |
| -- Process_Subprogram_Declaration for each remote subprogram. |
| |
| ------------------------- |
| -- Build_Package_Stubs -- |
| ------------------------- |
| |
| procedure Build_Package_Stubs (Pkg_Spec : Node_Id) is |
| Decls : constant List_Id := Visible_Declarations (Pkg_Spec); |
| Decl : Node_Id; |
| |
| procedure Visit_Nested_Pkg (Nested_Pkg_Decl : Node_Id); |
| -- Recurse for the given nested package declaration |
| |
| ----------------------- |
| -- Visit_Nested_Spec -- |
| ----------------------- |
| |
| procedure Visit_Nested_Pkg (Nested_Pkg_Decl : Node_Id) is |
| Nested_Pkg_Spec : constant Node_Id := Specification (Nested_Pkg_Decl); |
| begin |
| Push_Scope (Scope_Of_Spec (Nested_Pkg_Spec)); |
| Build_Package_Stubs (Nested_Pkg_Spec); |
| Pop_Scope; |
| end Visit_Nested_Pkg; |
| |
| -- Start of processing for Build_Package_Stubs |
| |
| begin |
| Decl := First (Decls); |
| while Present (Decl) loop |
| case Nkind (Decl) is |
| when N_Subprogram_Declaration => |
| |
| -- Note: we test Comes_From_Source on Spec, not Decl, because |
| -- in the case of a subprogram instance, only the specification |
| -- (not the declaration) is marked as coming from source. |
| |
| if Comes_From_Source (Specification (Decl)) then |
| Process_Subprogram_Declaration (Decl); |
| end if; |
| |
| when N_Package_Declaration => |
| |
| -- Case of a nested package or package instantiation coming |
| -- from source. Note that the anonymous wrapper package for |
| -- subprogram instances is not flagged Is_Generic_Instance at |
| -- this point, so there is a distinct circuit to handle them |
| -- (see case N_Subprogram_Instantiation below). |
| |
| declare |
| Pkg_Ent : constant Entity_Id := |
| Defining_Unit_Name (Specification (Decl)); |
| begin |
| if Comes_From_Source (Decl) |
| or else |
| (Is_Generic_Instance (Pkg_Ent) |
| and then Comes_From_Source |
| (Get_Package_Instantiation_Node (Pkg_Ent))) |
| then |
| Visit_Nested_Pkg (Decl); |
| end if; |
| end; |
| |
| when N_Subprogram_Instantiation => |
| |
| -- The subprogram declaration for an instance of a generic |
| -- subprogram is wrapped in a package that does not come from |
| -- source, so we need to explicitly traverse it here. |
| |
| if Comes_From_Source (Decl) then |
| Visit_Nested_Pkg (Instance_Spec (Decl)); |
| end if; |
| |
| when others => |
| null; |
| end case; |
| Next (Decl); |
| end loop; |
| end Build_Package_Stubs; |
| |
| --------------------------------------- |
| -- Add_Calling_Stubs_To_Declarations -- |
| --------------------------------------- |
| |
| procedure Add_Calling_Stubs_To_Declarations (Pkg_Spec : Node_Id) is |
| Loc : constant Source_Ptr := Sloc (Pkg_Spec); |
| |
| Current_Subprogram_Number : Int := First_RCI_Subprogram_Id; |
| -- Subprogram id 0 is reserved for calls received from |
| -- remote access-to-subprogram dereferences. |
| |
| RCI_Instantiation : Node_Id; |
| |
| procedure Visit_Subprogram (Decl : Node_Id); |
| -- Generate calling stub for one remote subprogram |
| |
| ---------------------- |
| -- Visit_Subprogram -- |
| ---------------------- |
| |
| procedure Visit_Subprogram (Decl : Node_Id) is |
| Loc : constant Source_Ptr := Sloc (Decl); |
| Spec : constant Node_Id := Specification (Decl); |
| Subp_Stubs : Node_Id; |
| |
| Subp_Str : String_Id; |
| pragma Warnings (Off, Subp_Str); |
| |
| begin |
| -- Disable expansion of stubs if serious errors have been diagnosed, |
| -- because otherwise some illegal remote subprogram declarations |
| -- could cause cascaded errors in stubs. |
| |
| if Serious_Errors_Detected /= 0 then |
| return; |
| end if; |
| |
| Assign_Subprogram_Identifier |
| (Defining_Unit_Name (Spec), Current_Subprogram_Number, Subp_Str); |
| |
| Subp_Stubs := |
| Build_Subprogram_Calling_Stubs |
| (Vis_Decl => Decl, |
| Subp_Id => |
| Build_Subprogram_Id (Loc, Defining_Unit_Name (Spec)), |
| Asynchronous => |
| Nkind (Spec) = N_Procedure_Specification |
| and then Is_Asynchronous (Defining_Unit_Name (Spec))); |
| |
| Append_To (List_Containing (Decl), Subp_Stubs); |
| Analyze (Subp_Stubs); |
| |
| Current_Subprogram_Number := Current_Subprogram_Number + 1; |
| end Visit_Subprogram; |
| |
| procedure Visit_Spec is new Build_Package_Stubs (Visit_Subprogram); |
| |
| -- Start of processing for Add_Calling_Stubs_To_Declarations |
| |
| begin |
| Push_Scope (Scope_Of_Spec (Pkg_Spec)); |
| |
| -- The first thing added is an instantiation of the generic package |
| -- System.Partition_Interface.RCI_Locator with the name of this remote |
| -- package. This will act as an interface with the name server to |
| -- determine the Partition_ID and the RPC_Receiver for the receiver |
| -- of this package. |
| |
| RCI_Instantiation := RCI_Package_Locator (Loc, Pkg_Spec); |
| RCI_Cache := Defining_Unit_Name (RCI_Instantiation); |
| |
| Append_To (Visible_Declarations (Pkg_Spec), RCI_Instantiation); |
| Analyze (RCI_Instantiation); |
| |
| -- For each subprogram declaration visible in the spec, we do build a |
| -- body. We also increment a counter to assign a different Subprogram_Id |
| -- to each subprogram. The receiving stubs processing uses the same |
| -- mechanism and will thus assign the same Id and do the correct |
| -- dispatching. |
| |
| Overload_Counter_Table.Reset; |
| PolyORB_Support.Reserve_NamingContext_Methods; |
| |
| Visit_Spec (Pkg_Spec); |
| |
| Pop_Scope; |
| end Add_Calling_Stubs_To_Declarations; |
| |
| ----------------------------- |
| -- Add_Parameter_To_NVList -- |
| ----------------------------- |
| |
| function Add_Parameter_To_NVList |
| (Loc : Source_Ptr; |
| NVList : Entity_Id; |
| Parameter : Entity_Id; |
| Constrained : Boolean; |
| RACW_Ctrl : Boolean := False; |
| Any : Entity_Id) return Node_Id |
| is |
| Parameter_Name_String : String_Id; |
| Parameter_Mode : Node_Id; |
| |
| function Parameter_Passing_Mode |
| (Loc : Source_Ptr; |
| Parameter : Entity_Id; |
| Constrained : Boolean) return Node_Id; |
| -- Return an expression that denotes the parameter passing mode to be |
| -- used for Parameter in distribution stubs, where Constrained is |
| -- Parameter's constrained status. |
| |
| ---------------------------- |
| -- Parameter_Passing_Mode -- |
| ---------------------------- |
| |
| function Parameter_Passing_Mode |
| (Loc : Source_Ptr; |
| Parameter : Entity_Id; |
| Constrained : Boolean) return Node_Id |
| is |
| Lib_RE : RE_Id; |
| |
| begin |
| if Out_Present (Parameter) then |
| if In_Present (Parameter) |
| or else not Constrained |
| then |
| -- Unconstrained formals must be translated |
| -- to 'in' or 'inout', not 'out', because |
| -- they need to be constrained by the actual. |
| |
| Lib_RE := RE_Mode_Inout; |
| else |
| Lib_RE := RE_Mode_Out; |
| end if; |
| |
| else |
| Lib_RE := RE_Mode_In; |
| end if; |
| |
| return New_Occurrence_Of (RTE (Lib_RE), Loc); |
| end Parameter_Passing_Mode; |
| |
| -- Start of processing for Add_Parameter_To_NVList |
| |
| begin |
| if Nkind (Parameter) = N_Defining_Identifier then |
| Get_Name_String (Chars (Parameter)); |
| else |
| Get_Name_String (Chars (Defining_Identifier (Parameter))); |
| end if; |
| |
| Parameter_Name_String := String_From_Name_Buffer; |
| |
| if RACW_Ctrl or else Nkind (Parameter) = N_Defining_Identifier then |
| |
| -- When the parameter passed to Add_Parameter_To_NVList is an |
| -- Extra_Constrained parameter, Parameter is an N_Defining_ |
| -- Identifier, instead of a complete N_Parameter_Specification. |
| -- Thus, we explicitly set 'in' mode in this case. |
| |
| Parameter_Mode := New_Occurrence_Of (RTE (RE_Mode_In), Loc); |
| |
| else |
| Parameter_Mode := |
| Parameter_Passing_Mode (Loc, Parameter, Constrained); |
| end if; |
| |
| return |
| Make_Procedure_Call_Statement (Loc, |
| Name => |
| New_Occurrence_Of (RTE (RE_NVList_Add_Item), Loc), |
| Parameter_Associations => New_List ( |
| New_Occurrence_Of (NVList, Loc), |
| Make_Function_Call (Loc, |
| Name => |
| New_Occurrence_Of (RTE (RE_To_PolyORB_String), Loc), |
| Parameter_Associations => New_List ( |
| Make_String_Literal (Loc, Strval => Parameter_Name_String))), |
| New_Occurrence_Of (Any, Loc), |
| Parameter_Mode)); |
| end Add_Parameter_To_NVList; |
| |
| -------------------------------- |
| -- Add_RACW_Asynchronous_Flag -- |
| -------------------------------- |
| |
| procedure Add_RACW_Asynchronous_Flag |
| (Declarations : List_Id; |
| RACW_Type : Entity_Id) |
| is |
| Loc : constant Source_Ptr := Sloc (RACW_Type); |
| |
| Asynchronous_Flag : constant Entity_Id := |
| Make_Defining_Identifier (Loc, |
| New_External_Name (Chars (RACW_Type), 'A')); |
| |
| begin |
| -- Declare the asynchronous flag. This flag will be changed to True |
| -- whenever it is known that the RACW type is asynchronous. |
| |
| Append_To (Declarations, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Asynchronous_Flag, |
| Constant_Present => True, |
| Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc), |
| Expression => New_Occurrence_Of (Standard_False, Loc))); |
| |
| Asynchronous_Flags_Table.Set (RACW_Type, Asynchronous_Flag); |
| end Add_RACW_Asynchronous_Flag; |
| |
| ----------------------- |
| -- Add_RACW_Features -- |
| ----------------------- |
| |
| procedure Add_RACW_Features (RACW_Type : Entity_Id) is |
| Desig : constant Entity_Id := Etype (Designated_Type (RACW_Type)); |
| Same_Scope : constant Boolean := Scope (Desig) = Scope (RACW_Type); |
| |
| Pkg_Spec : Node_Id; |
| Decls : List_Id; |
| Body_Decls : List_Id; |
| |
| Stub_Type : Entity_Id; |
| Stub_Type_Access : Entity_Id; |
| RPC_Receiver_Decl : Node_Id; |
| |
| Existing : Boolean; |
| -- True when appropriate stubs have already been generated (this is the |
| -- case when another RACW with the same designated type has already been |
| -- encountered), in which case we reuse the previous stubs rather than |
| -- generating new ones. |
| |
| begin |
| if not Expander_Active then |
| return; |
| end if; |
| |
| -- Mark the current package declaration as containing an RACW, so that |
| -- the bodies for the calling stubs and the RACW stream subprograms |
| -- are attached to the tree when the corresponding body is encountered. |
| |
| Set_Has_RACW (Current_Scope); |
| |
| -- Look for place to declare the RACW stub type and RACW operations |
| |
| Pkg_Spec := Empty; |
| |
| if Same_Scope then |
| |
| -- Case of declaring the RACW in the same package as its designated |
| -- type: we know that the designated type is a private type, so we |
| -- use the private declarations list. |
| |
| Pkg_Spec := Package_Specification_Of_Scope (Current_Scope); |
| |
| if Present (Private_Declarations (Pkg_Spec)) then |
| Decls := Private_Declarations (Pkg_Spec); |
| else |
| Decls := Visible_Declarations (Pkg_Spec); |
| end if; |
| |
| else |
| -- Case of declaring the RACW in another package than its designated |
| -- type: use the private declarations list if present; otherwise |
| -- use the visible declarations. |
| |
| Decls := List_Containing (Declaration_Node (RACW_Type)); |
| |
| end if; |
| |
| -- If we were unable to find the declarations, that means that the |
| -- completion of the type was missing. We can safely return and let the |
| -- error be caught by the semantic analysis. |
| |
| if No (Decls) then |
| return; |
| end if; |
| |
| Add_Stub_Type |
| (Designated_Type => Desig, |
| RACW_Type => RACW_Type, |
| Decls => Decls, |
| Stub_Type => Stub_Type, |
| Stub_Type_Access => Stub_Type_Access, |
| RPC_Receiver_Decl => RPC_Receiver_Decl, |
| Body_Decls => Body_Decls, |
| Existing => Existing); |
| |
| -- If this RACW is not in the main unit, do not generate primitive or |
| -- TSS bodies. |
| |
| if not Entity_Is_In_Main_Unit (RACW_Type) then |
| Body_Decls := No_List; |
| end if; |
| |
| Add_RACW_Asynchronous_Flag |
| (Declarations => Decls, |
| RACW_Type => RACW_Type); |
| |
| Specific_Add_RACW_Features |
| (RACW_Type => RACW_Type, |
| Desig => Desig, |
| Stub_Type => Stub_Type, |
| Stub_Type_Access => Stub_Type_Access, |
| RPC_Receiver_Decl => RPC_Receiver_Decl, |
| Body_Decls => Body_Decls); |
| |
| -- If we already have stubs for this designated type, nothing to do |
| |
| if Existing then |
| return; |
| end if; |
| |
| if Is_Frozen (Desig) then |
| Validate_RACW_Primitives (RACW_Type); |
| Add_RACW_Primitive_Declarations_And_Bodies |
| (Designated_Type => Desig, |
| Insertion_Node => RPC_Receiver_Decl, |
| Body_Decls => Body_Decls); |
| |
| else |
| -- Validate_RACW_Primitives requires the list of all primitives of |
| -- the designated type, so defer processing until Desig is frozen. |
| -- See Exp_Ch3.Freeze_Type. |
| |
| Add_Access_Type_To_Process (E => Desig, A => RACW_Type); |
| end if; |
| end Add_RACW_Features; |
| |
| ------------------------------------------------ |
| -- Add_RACW_Primitive_Declarations_And_Bodies -- |
| ------------------------------------------------ |
| |
| procedure Add_RACW_Primitive_Declarations_And_Bodies |
| (Designated_Type : Entity_Id; |
| Insertion_Node : Node_Id; |
| Body_Decls : List_Id) |
| is |
| Loc : constant Source_Ptr := Sloc (Insertion_Node); |
| -- Set Sloc of generated declaration copy of insertion node Sloc, so |
| -- the declarations are recognized as belonging to the current package. |
| |
| Stub_Elements : constant Stub_Structure := |
| Stubs_Table.Get (Designated_Type); |
| |
| pragma Assert (Stub_Elements /= Empty_Stub_Structure); |
| |
| Is_RAS : constant Boolean := |
| not Comes_From_Source (Stub_Elements.RACW_Type); |
| -- Case of the RACW generated to implement a remote access-to- |
| -- subprogram type. |
| |
| Build_Bodies : constant Boolean := |
| In_Extended_Main_Code_Unit (Stub_Elements.Stub_Type); |
| -- True when bodies must be prepared in Body_Decls. Bodies are generated |
| -- only when the main unit is the unit that contains the stub type. |
| |
| Current_Insertion_Node : Node_Id := Insertion_Node; |
| |
| RPC_Receiver : Entity_Id; |
| RPC_Receiver_Statements : List_Id; |
| RPC_Receiver_Case_Alternatives : constant List_Id := New_List; |
| RPC_Receiver_Elsif_Parts : List_Id; |
| RPC_Receiver_Request : Entity_Id; |
| RPC_Receiver_Subp_Id : Entity_Id; |
| RPC_Receiver_Subp_Index : Entity_Id; |
| |
| Subp_Str : String_Id; |
| |
| Current_Primitive_Elmt : Elmt_Id; |
| Current_Primitive : Entity_Id; |
| Current_Primitive_Body : Node_Id; |
| Current_Primitive_Spec : Node_Id; |
| Current_Primitive_Decl : Node_Id; |
| Current_Primitive_Number : Int := 0; |
| Current_Primitive_Alias : Node_Id; |
| Current_Receiver : Entity_Id; |
| Current_Receiver_Body : Node_Id; |
| RPC_Receiver_Decl : Node_Id; |
| Possibly_Asynchronous : Boolean; |
| |
| begin |
| if not Expander_Active then |
| return; |
| end if; |
| |
| if not Is_RAS then |
| RPC_Receiver := Make_Temporary (Loc, 'P'); |
| |
| Specific_Build_RPC_Receiver_Body |
| (RPC_Receiver => RPC_Receiver, |
| Request => RPC_Receiver_Request, |
| Subp_Id => RPC_Receiver_Subp_Id, |
| Subp_Index => RPC_Receiver_Subp_Index, |
| Stmts => RPC_Receiver_Statements, |
| Decl => RPC_Receiver_Decl); |
| |
| if Get_PCS_Name = Name_PolyORB_DSA then |
| |
| -- For the case of PolyORB, we need to map a textual operation |
| -- name into a primitive index. Currently we do so using a simple |
| -- sequence of string comparisons. |
| |
| RPC_Receiver_Elsif_Parts := New_List; |
| end if; |
| end if; |
| |
| -- Build callers, receivers for every primitive operations and a RPC |
| -- receiver for this type. Note that we use Direct_Primitive_Operations, |
| -- not Primitive_Operations, because we really want just the primitives |
| -- of the tagged type itself, and in the case of a tagged synchronized |
| -- type we do not want to get the primitives of the corresponding |
| -- record type). |
| |
| if Present (Direct_Primitive_Operations (Designated_Type)) then |
| Overload_Counter_Table.Reset; |
| |
| Current_Primitive_Elmt := |
| First_Elmt (Direct_Primitive_Operations (Designated_Type)); |
| while Current_Primitive_Elmt /= No_Elmt loop |
| Current_Primitive := Node (Current_Primitive_Elmt); |
| |
| -- Copy the primitive of all the parents, except predefined ones |
| -- that are not remotely dispatching. Also omit hidden primitives |
| -- (occurs in the case of primitives of interface progenitors |
| -- other than immediate ancestors of the Designated_Type). |
| |
| if Chars (Current_Primitive) /= Name_uSize |
| and then Chars (Current_Primitive) /= Name_uAlignment |
| and then not |
| (Is_TSS (Current_Primitive, TSS_Deep_Finalize) or else |
| Is_TSS (Current_Primitive, TSS_Stream_Input) or else |
| Is_TSS (Current_Primitive, TSS_Stream_Output) or else |
| Is_TSS (Current_Primitive, TSS_Stream_Read) or else |
| Is_TSS (Current_Primitive, TSS_Stream_Write) |
| or else |
| Is_Predefined_Interface_Primitive (Current_Primitive)) |
| and then not Is_Hidden (Current_Primitive) |
| then |
| -- The first thing to do is build an up-to-date copy of the |
| -- spec with all the formals referencing Controlling_Type |
| -- transformed into formals referencing Stub_Type. Since this |
| -- primitive may have been inherited, go back the alias chain |
| -- until the real primitive has been found. |
| |
| Current_Primitive_Alias := Ultimate_Alias (Current_Primitive); |
| |
| -- Copy the spec from the original declaration for the purpose |
| -- of declaring an overriding subprogram: we need to replace |
| -- the type of each controlling formal with Stub_Type. The |
| -- primitive may have been declared for Controlling_Type or |
| -- inherited from some ancestor type for which we do not have |
| -- an easily determined Entity_Id. We have no systematic way |
| -- of knowing which type to substitute Stub_Type for. Instead, |
| -- Copy_Specification relies on the flag Is_Controlling_Formal |
| -- to determine which formals to change. |
| |
| Current_Primitive_Spec := |
| Copy_Specification (Loc, |
| Spec => Parent (Current_Primitive_Alias), |
| Ctrl_Type => Stub_Elements.Stub_Type); |
| |
| Current_Primitive_Decl := |
| Make_Subprogram_Declaration (Loc, |
| Specification => Current_Primitive_Spec); |
| |
| Insert_After_And_Analyze (Current_Insertion_Node, |
| Current_Primitive_Decl); |
| Current_Insertion_Node := Current_Primitive_Decl; |
| |
| Possibly_Asynchronous := |
| Nkind (Current_Primitive_Spec) = N_Procedure_Specification |
| and then Could_Be_Asynchronous (Current_Primitive_Spec); |
| |
| Assign_Subprogram_Identifier ( |
| Defining_Unit_Name (Current_Primitive_Spec), |
| Current_Primitive_Number, |
| Subp_Str); |
| |
| if Build_Bodies then |
| Current_Primitive_Body := |
| Build_Subprogram_Calling_Stubs |
| (Vis_Decl => Current_Primitive_Decl, |
| Subp_Id => |
| Build_Subprogram_Id (Loc, |
| Defining_Unit_Name (Current_Primitive_Spec)), |
| Asynchronous => Possibly_Asynchronous, |
| Dynamically_Asynchronous => Possibly_Asynchronous, |
| Stub_Type => Stub_Elements.Stub_Type, |
| RACW_Type => Stub_Elements.RACW_Type); |
| Append_To (Body_Decls, Current_Primitive_Body); |
| |
| -- Analyzing the body here would cause the Stub type to |
| -- be frozen, thus preventing subsequent primitive |
| -- declarations. For this reason, it will be analyzed |
| -- later in the regular flow (and in the context of the |
| -- appropriate unit body, see Append_RACW_Bodies). |
| |
| end if; |
| |
| -- Build the receiver stubs |
| |
| if Build_Bodies and then not Is_RAS then |
| Current_Receiver_Body := |
| Specific_Build_Subprogram_Receiving_Stubs |
| (Vis_Decl => Current_Primitive_Decl, |
| Asynchronous => Possibly_Asynchronous, |
| Dynamically_Asynchronous => Possibly_Asynchronous, |
| Stub_Type => Stub_Elements.Stub_Type, |
| RACW_Type => Stub_Elements.RACW_Type, |
| Parent_Primitive => Current_Primitive); |
| |
| Current_Receiver := |
| Defining_Unit_Name (Specification (Current_Receiver_Body)); |
| |
| Append_To (Body_Decls, Current_Receiver_Body); |
| |
| -- Add a case alternative to the receiver |
| |
| if Get_PCS_Name = Name_PolyORB_DSA then |
| Append_To (RPC_Receiver_Elsif_Parts, |
| Make_Elsif_Part (Loc, |
| Condition => |
| Make_Function_Call (Loc, |
| Name => |
| New_Occurrence_Of ( |
| RTE (RE_Caseless_String_Eq), Loc), |
| Parameter_Associations => New_List ( |
| New_Occurrence_Of (RPC_Receiver_Subp_Id, Loc), |
| Make_String_Literal (Loc, Subp_Str))), |
| |
| Then_Statements => New_List ( |
| Make_Assignment_Statement (Loc, |
| Name => New_Occurrence_Of ( |
| RPC_Receiver_Subp_Index, Loc), |
| Expression => |
| Make_Integer_Literal (Loc, |
| Intval => Current_Primitive_Number))))); |
| end if; |
| |
| Append_To (RPC_Receiver_Case_Alternatives, |
| Make_Case_Statement_Alternative (Loc, |
| Discrete_Choices => New_List ( |
| Make_Integer_Literal (Loc, Current_Primitive_Number)), |
| |
| Statements => New_List ( |
| Make_Procedure_Call_Statement (Loc, |
| Name => |
| New_Occurrence_Of (Current_Receiver, Loc), |
| Parameter_Associations => New_List ( |
| New_Occurrence_Of (RPC_Receiver_Request, Loc)))))); |
| end if; |
| |
| -- Increment the index of current primitive |
| |
| Current_Primitive_Number := Current_Primitive_Number + 1; |
| end if; |
| |
| Next_Elmt (Current_Primitive_Elmt); |
| end loop; |
| end if; |
| |
| -- Build the case statement and the heart of the subprogram |
| |
| if Build_Bodies and then not Is_RAS then |
| if Get_PCS_Name = Name_PolyORB_DSA |
| and then Present (First (RPC_Receiver_Elsif_Parts)) |
| then |
| Append_To (RPC_Receiver_Statements, |
| Make_Implicit_If_Statement (Designated_Type, |
| Condition => New_Occurrence_Of (Standard_False, Loc), |
| Then_Statements => New_List, |
| Elsif_Parts => RPC_Receiver_Elsif_Parts)); |
| end if; |
| |
| Append_To (RPC_Receiver_Case_Alternatives, |
| Make_Case_Statement_Alternative (Loc, |
| Discrete_Choices => New_List (Make_Others_Choice (Loc)), |
| Statements => New_List (Make_Null_Statement (Loc)))); |
| |
| Append_To (RPC_Receiver_Statements, |
| Make_Case_Statement (Loc, |
| Expression => |
| New_Occurrence_Of (RPC_Receiver_Subp_Index, Loc), |
| Alternatives => RPC_Receiver_Case_Alternatives)); |
| |
| Append_To (Body_Decls, RPC_Receiver_Decl); |
| Specific_Add_Obj_RPC_Receiver_Completion (Loc, |
| Body_Decls, RPC_Receiver, Stub_Elements); |
| |
| -- Do not analyze RPC receiver body at this stage since it references |
| -- subprograms that have not been analyzed yet. It will be analyzed in |
| -- the regular flow (see Append_RACW_Bodies). |
| |
| end if; |
| end Add_RACW_Primitive_Declarations_And_Bodies; |
| |
| ----------------------------- |
| -- Add_RAS_Dereference_TSS -- |
| ----------------------------- |
| |
| procedure Add_RAS_Dereference_TSS (N : Node_Id) is |
| Loc : constant Source_Ptr := Sloc (N); |
| |
| Type_Def : constant Node_Id := Type_Definition (N); |
| RAS_Type : constant Entity_Id := Defining_Identifier (N); |
| Fat_Type : constant Entity_Id := Equivalent_Type (RAS_Type); |
| RACW_Type : constant Entity_Id := Underlying_RACW_Type (RAS_Type); |
| |
| RACW_Primitive_Name : Node_Id; |
| |
| Proc : constant Entity_Id := |
| Make_Defining_Identifier (Loc, |
| Chars => Make_TSS_Name (RAS_Type, TSS_RAS_Dereference)); |
| |
| Proc_Spec : Node_Id; |
| Param_Specs : List_Id; |
| Param_Assoc : constant List_Id := New_List; |
| Stmts : constant List_Id := New_List; |
| |
| RAS_Parameter : constant Entity_Id := Make_Temporary (Loc, 'P'); |
| |
| Is_Function : constant Boolean := |
| Nkind (Type_Def) = N_Access_Function_Definition; |
| |
| Is_Degenerate : Boolean; |
| -- Set to True if the subprogram_specification for this RAS has an |
| -- anonymous access parameter (see Process_Remote_AST_Declaration). |
| |
| Spec : constant Node_Id := Type_Def; |
| |
| Current_Parameter : Node_Id; |
| |
| -- Start of processing for Add_RAS_Dereference_TSS |
| |
| begin |
| -- The Dereference TSS for a remote access-to-subprogram type has the |
| -- form: |
| |
| -- [function|procedure] ras_typeRD (RAS_Value, <RAS_Parameters>) |
| -- [return <>] |
| |
| -- This is called whenever a value of a RAS type is dereferenced |
| |
| -- First construct a list of parameter specifications: |
| |
| -- The first formal is the RAS values |
| |
| Param_Specs := New_List ( |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => RAS_Parameter, |
| In_Present => True, |
| Parameter_Type => |
| New_Occurrence_Of (Fat_Type, Loc))); |
| |
| -- The following formals are copied from the type declaration |
| |
| Is_Degenerate := False; |
| Current_Parameter := First (Parameter_Specifications (Type_Def)); |
| Parameters : while Present (Current_Parameter) loop |
| if Nkind (Parameter_Type (Current_Parameter)) = |
| N_Access_Definition |
| then |
| Is_Degenerate := True; |
| end if; |
| |
| Append_To (Param_Specs, |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, |
| Chars => Chars (Defining_Identifier (Current_Parameter))), |
| In_Present => In_Present (Current_Parameter), |
| Out_Present => Out_Present (Current_Parameter), |
| Parameter_Type => |
| New_Copy_Tree (Parameter_Type (Current_Parameter)), |
| Expression => |
| New_Copy_Tree (Expression (Current_Parameter)))); |
| |
| Append_To (Param_Assoc, |
| Make_Identifier (Loc, |
| Chars => Chars (Defining_Identifier (Current_Parameter)))); |
| |
| Next (Current_Parameter); |
| end loop Parameters; |
| |
| if Is_Degenerate then |
| Prepend_To (Param_Assoc, New_Occurrence_Of (RAS_Parameter, Loc)); |
| |
| -- Generate a dummy body. This code will never actually be executed, |
| -- because null is the only legal value for a degenerate RAS type. |
| -- For legality's sake (in order to avoid generating a function that |
| -- does not contain a return statement), we include a dummy recursive |
| -- call on the TSS itself. |
| |
| Append_To (Stmts, |
| Make_Raise_Program_Error (Loc, Reason => PE_Explicit_Raise)); |
| RACW_Primitive_Name := New_Occurrence_Of (Proc, Loc); |
| |
| else |
| -- For a normal RAS type, we cast the RAS formal to the corresponding |
| -- tagged type, and perform a dispatching call to its Call primitive |
| -- operation. |
| |
| Prepend_To (Param_Assoc, |
| Unchecked_Convert_To (RACW_Type, |
| New_Occurrence_Of (RAS_Parameter, Loc))); |
| |
| RACW_Primitive_Name := |
| Make_Selected_Component (Loc, |
| Prefix => Scope (RACW_Type), |
| Selector_Name => Name_uCall); |
| end if; |
| |
| if Is_Function then |
| Append_To (Stmts, |
| Make_Simple_Return_Statement (Loc, |
| Expression => |
| Make_Function_Call (Loc, |
| Name => RACW_Primitive_Name, |
| Parameter_Associations => Param_Assoc))); |
| |
| else |
| Append_To (Stmts, |
| Make_Procedure_Call_Statement (Loc, |
| Name => RACW_Primitive_Name, |
| Parameter_Associations => Param_Assoc)); |
| end if; |
| |
| -- Build the complete subprogram |
| |
| if Is_Function then |
| Proc_Spec := |
| Make_Function_Specification (Loc, |
| Defining_Unit_Name => Proc, |
| Parameter_Specifications => Param_Specs, |
| Result_Definition => |
| New_Occurrence_Of ( |
| Entity (Result_Definition (Spec)), Loc)); |
| |
| Set_Ekind (Proc, E_Function); |
| Set_Etype (Proc, |
| New_Occurrence_Of (Entity (Result_Definition (Spec)), Loc)); |
| |
| else |
| Proc_Spec := |
| Make_Procedure_Specification (Loc, |
| Defining_Unit_Name => Proc, |
| Parameter_Specifications => Param_Specs); |
| |
| Set_Ekind (Proc, E_Procedure); |
| Set_Etype (Proc, Standard_Void_Type); |
| end if; |
| |
| Discard_Node ( |
| Make_Subprogram_Body (Loc, |
| Specification => Proc_Spec, |
| Declarations => New_List, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => Stmts))); |
| |
| Set_TSS (Fat_Type, Proc); |
| end Add_RAS_Dereference_TSS; |
| |
| ------------------------------- |
| -- Add_RAS_Proxy_And_Analyze -- |
| ------------------------------- |
| |
| procedure Add_RAS_Proxy_And_Analyze |
| (Decls : List_Id; |
| Vis_Decl : Node_Id; |
| All_Calls_Remote_E : Entity_Id; |
| Proxy_Object_Addr : out Entity_Id) |
| is |
| Loc : constant Source_Ptr := Sloc (Vis_Decl); |
| |
| Subp_Name : constant Entity_Id := |
| Defining_Unit_Name (Specification (Vis_Decl)); |
| |
| Pkg_Name : constant Entity_Id := |
| Make_Defining_Identifier (Loc, |
| Chars => New_External_Name (Chars (Subp_Name), 'P', -1)); |
| |
| Proxy_Type : constant Entity_Id := |
| Make_Defining_Identifier (Loc, |
| Chars => |
| New_External_Name |
| (Related_Id => Chars (Subp_Name), |
| Suffix => 'P')); |
| |
| Proxy_Type_Full_View : constant Entity_Id := |
| Make_Defining_Identifier (Loc, |
| Chars (Proxy_Type)); |
| |
| Subp_Decl_Spec : constant Node_Id := |
| Build_RAS_Primitive_Specification |
| (Subp_Spec => Specification (Vis_Decl), |
| Remote_Object_Type => Proxy_Type); |
| |
| Subp_Body_Spec : constant Node_Id := |
| Build_RAS_Primitive_Specification |
| (Subp_Spec => Specification (Vis_Decl), |
| Remote_Object_Type => Proxy_Type); |
| |
| Vis_Decls : constant List_Id := New_List; |
| Pvt_Decls : constant List_Id := New_List; |
| Actuals : constant List_Id := New_List; |
| Formal : Node_Id; |
| Perform_Call : Node_Id; |
| |
| begin |
| -- type subpP is tagged limited private; |
| |
| Append_To (Vis_Decls, |
| Make_Private_Type_Declaration (Loc, |
| Defining_Identifier => Proxy_Type, |
| Tagged_Present => True, |
| Limited_Present => True)); |
| |
| -- [subprogram] Call |
| -- (Self : access subpP; |
| -- ...other-formals...) |
| -- [return T]; |
| |
| Append_To (Vis_Decls, |
| Make_Subprogram_Declaration (Loc, |
| Specification => Subp_Decl_Spec)); |
| |
| -- A : constant System.Address; |
| |
| Proxy_Object_Addr := Make_Defining_Identifier (Loc, Name_uA); |
| |
| Append_To (Vis_Decls, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Proxy_Object_Addr, |
| Constant_Present => True, |
| Object_Definition => New_Occurrence_Of (RTE (RE_Address), Loc))); |
| |
| -- private |
| |
| -- type subpP is tagged limited record |
| -- All_Calls_Remote : Boolean := [All_Calls_Remote?]; |
| -- ... |
| -- end record; |
| |
| Append_To (Pvt_Decls, |
| Make_Full_Type_Declaration (Loc, |
| Defining_Identifier => Proxy_Type_Full_View, |
| Type_Definition => |
| Build_Remote_Subprogram_Proxy_Type (Loc, |
| New_Occurrence_Of (All_Calls_Remote_E, Loc)))); |
| |
| -- Trick semantic analysis into swapping the public and full view when |
| -- freezing the public view. |
| |
| Set_Comes_From_Source (Proxy_Type_Full_View, True); |
| |
| -- procedure Call |
| -- (Self : access O; |
| -- ...other-formals...) is |
| -- begin |
| -- P (...other-formals...); |
| -- end Call; |
| |
| -- function Call |
| -- (Self : access O; |
| -- ...other-formals...) |
| -- return T is |
| -- begin |
| -- return F (...other-formals...); |
| -- end Call; |
| |
| if Nkind (Subp_Decl_Spec) = N_Procedure_Specification then |
| Perform_Call := |
| Make_Procedure_Call_Statement (Loc, |
| Name => New_Occurrence_Of (Subp_Name, Loc), |
| Parameter_Associations => Actuals); |
| else |
| Perform_Call := |
| Make_Simple_Return_Statement (Loc, |
| Expression => |
| Make_Function_Call (Loc, |
| Name => New_Occurrence_Of (Subp_Name, Loc), |
| Parameter_Associations => Actuals)); |
| end if; |
| |
| Formal := First (Parameter_Specifications (Subp_Decl_Spec)); |
| pragma Assert (Present (Formal)); |
| loop |
| Next (Formal); |
| exit when No (Formal); |
| Append_To (Actuals, |
| New_Occurrence_Of (Defining_Identifier (Formal), Loc)); |
| end loop; |
| |
| -- O : aliased subpP; |
| |
| Append_To (Pvt_Decls, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Make_Defining_Identifier (Loc, Name_uO), |
| Aliased_Present => True, |
| Object_Definition => New_Occurrence_Of (Proxy_Type, Loc))); |
| |
| -- A : constant System.Address := O'Address; |
| |
| Append_To (Pvt_Decls, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, Chars (Proxy_Object_Addr)), |
| Constant_Present => True, |
| Object_Definition => New_Occurrence_Of (RTE (RE_Address), Loc), |
| Expression => |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Occurrence_Of ( |
| Defining_Identifier (Last (Pvt_Decls)), Loc), |
| Attribute_Name => Name_Address))); |
| |
| Append_To (Decls, |
| Make_Package_Declaration (Loc, |
| Specification => Make_Package_Specification (Loc, |
| Defining_Unit_Name => Pkg_Name, |
| Visible_Declarations => Vis_Decls, |
| Private_Declarations => Pvt_Decls, |
| End_Label => Empty))); |
| Analyze (Last (Decls)); |
| |
| Append_To (Decls, |
| Make_Package_Body (Loc, |
| Defining_Unit_Name => |
| Make_Defining_Identifier (Loc, Chars (Pkg_Name)), |
| Declarations => New_List ( |
| Make_Subprogram_Body (Loc, |
| Specification => Subp_Body_Spec, |
| Declarations => New_List, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => New_List (Perform_Call)))))); |
| Analyze (Last (Decls)); |
| end Add_RAS_Proxy_And_Analyze; |
| |
| ----------------------- |
| -- Add_RAST_Features -- |
| ----------------------- |
| |
| procedure Add_RAST_Features (Vis_Decl : Node_Id) is |
| RAS_Type : constant Entity_Id := |
| Equivalent_Type (Defining_Identifier (Vis_Decl)); |
| begin |
| pragma Assert (No (TSS (RAS_Type, TSS_RAS_Access))); |
| Add_RAS_Dereference_TSS (Vis_Decl); |
| Specific_Add_RAST_Features (Vis_Decl, RAS_Type); |
| end Add_RAST_Features; |
| |
| ------------------- |
| -- Add_Stub_Type -- |
| ------------------- |
| |
| procedure Add_Stub_Type |
| (Designated_Type : Entity_Id; |
| RACW_Type : Entity_Id; |
| Decls : List_Id; |
| Stub_Type : out Entity_Id; |
| Stub_Type_Access : out Entity_Id; |
| RPC_Receiver_Decl : out Node_Id; |
| Body_Decls : out List_Id; |
| Existing : out Boolean) |
| is |
| Loc : constant Source_Ptr := Sloc (RACW_Type); |
| |
| Stub_Elements : constant Stub_Structure := |
| Stubs_Table.Get (Designated_Type); |
| Stub_Type_Decl : Node_Id; |
| Stub_Type_Access_Decl : Node_Id; |
| |
| begin |
| if Stub_Elements /= Empty_Stub_Structure then |
| Stub_Type := Stub_Elements.Stub_Type; |
| Stub_Type_Access := Stub_Elements.Stub_Type_Access; |
| RPC_Receiver_Decl := Stub_Elements.RPC_Receiver_Decl; |
| Body_Decls := Stub_Elements.Body_Decls; |
| Existing := True; |
| return; |
| end if; |
| |
| Existing := False; |
| Stub_Type := Make_Temporary (Loc, 'S'); |
| Set_Ekind (Stub_Type, E_Record_Type); |
| Set_Is_RACW_Stub_Type (Stub_Type); |
| Stub_Type_Access := |
| Make_Defining_Identifier (Loc, |
| Chars => New_External_Name |
| (Related_Id => Chars (Stub_Type), Suffix => 'A')); |
| |
| RPC_Receiver_Decl := Specific_RPC_Receiver_Decl (RACW_Type); |
| |
| -- Create new stub type, copying components from generic RACW_Stub_Type |
| |
| Stub_Type_Decl := |
| Make_Full_Type_Declaration (Loc, |
| Defining_Identifier => Stub_Type, |
| Type_Definition => |
| Make_Record_Definition (Loc, |
| Tagged_Present => True, |
| Limited_Present => True, |
| Component_List => |
| Make_Component_List (Loc, |
| Component_Items => |
| Copy_Component_List (RTE (RE_RACW_Stub_Type), Loc)))); |
| |
| -- Does the stub type need to explicitly implement interfaces from the |
| -- designated type??? |
| |
| -- In particular are there issues in the case where the designated type |
| -- is a synchronized interface??? |
| |
| Stub_Type_Access_Decl := |
| Make_Full_Type_Declaration (Loc, |
| Defining_Identifier => Stub_Type_Access, |
| Type_Definition => |
| Make_Access_To_Object_Definition (Loc, |
| All_Present => True, |
| Subtype_Indication => New_Occurrence_Of (Stub_Type, Loc))); |
| |
| Append_To (Decls, Stub_Type_Decl); |
| Analyze (Last (Decls)); |
| Append_To (Decls, Stub_Type_Access_Decl); |
| Analyze (Last (Decls)); |
| |
| -- We can't directly derive the stub type from the designated type, |
| -- because we don't want any components or discriminants from the real |
| -- type, so instead we manually fake a derivation to get an appropriate |
| -- dispatch table. |
| |
| Derive_Subprograms (Parent_Type => Designated_Type, |
| Derived_Type => Stub_Type); |
| |
| if Present (RPC_Receiver_Decl) then |
| Append_To (Decls, RPC_Receiver_Decl); |
| |
| else |
| -- Case of RACW implementing a RAS with the GARLIC PCS: there is |
| -- no RPC receiver in that case, this is just an indication of |
| -- where to insert code in the tree (see comment in declaration of |
| -- type Stub_Structure). |
| |
| RPC_Receiver_Decl := Last (Decls); |
| end if; |
| |
| Body_Decls := New_List; |
| |
| Stubs_Table.Set (Designated_Type, |
| (Stub_Type => Stub_Type, |
| Stub_Type_Access => Stub_Type_Access, |
| RPC_Receiver_Decl => RPC_Receiver_Decl, |
| Body_Decls => Body_Decls, |
| RACW_Type => RACW_Type)); |
| end Add_Stub_Type; |
| |
| ------------------------ |
| -- Append_RACW_Bodies -- |
| ------------------------ |
| |
| procedure Append_RACW_Bodies (Decls : List_Id; Spec_Id : Entity_Id) is |
| E : Entity_Id; |
| |
| begin |
| E := First_Entity (Spec_Id); |
| while Present (E) loop |
| if Is_Remote_Access_To_Class_Wide_Type (E) then |
| Append_List_To (Decls, Get_And_Reset_RACW_Bodies (E)); |
| end if; |
| |
| Next_Entity (E); |
| end loop; |
| end Append_RACW_Bodies; |
| |
| ---------------------------------- |
| -- Assign_Subprogram_Identifier -- |
| ---------------------------------- |
| |
| procedure Assign_Subprogram_Identifier |
| (Def : Entity_Id; |
| Spn : Int; |
| Id : out String_Id) |
| is |
| N : constant Name_Id := Chars (Def); |
| |
| Overload_Order : constant Int := Overload_Counter_Table.Get (N) + 1; |
| |
| begin |
| Overload_Counter_Table.Set (N, Overload_Order); |
| |
| Get_Name_String (N); |
| |
| -- Homonym handling: as in Exp_Dbug, but much simpler, because the only |
| -- entities for which we have to generate names here need only to be |
| -- disambiguated within their own scope. |
| |
| if Overload_Order > 1 then |
| Name_Buffer (Name_Len + 1 .. Name_Len + 2) := "__"; |
| Name_Len := Name_Len + 2; |
| Add_Nat_To_Name_Buffer (Overload_Order); |
| end if; |
| |
| Id := String_From_Name_Buffer; |
| Subprogram_Identifier_Table.Set |
| (Def, |
| Subprogram_Identifiers'(Str_Identifier => Id, Int_Identifier => Spn)); |
| end Assign_Subprogram_Identifier; |
| |
| ------------------------------------- |
| -- Build_Actual_Object_Declaration -- |
| ------------------------------------- |
| |
| procedure Build_Actual_Object_Declaration |
| (Object : Entity_Id; |
| Etyp : Entity_Id; |
| Variable : Boolean; |
| Expr : Node_Id; |
| Decls : List_Id) |
| is |
| Loc : constant Source_Ptr := Sloc (Object); |
| |
| begin |
| -- Declare a temporary object for the actual, possibly initialized with |
| -- a 'Input/From_Any call. |
| |
| -- Complication arises in the case of limited types, for which such a |
| -- declaration is illegal in Ada 95. In that case, we first generate a |
| -- renaming declaration of the 'Input call, and then if needed we |
| -- generate an overlaid non-constant view. |
| |
| if Ada_Version <= Ada_95 |
| and then Is_Limited_Type (Etyp) |
| and then Present (Expr) |
| then |
| |
| -- Object : Etyp renames <func-call> |
| |
| Append_To (Decls, |
| Make_Object_Renaming_Declaration (Loc, |
| Defining_Identifier => Object, |
| Subtype_Mark => New_Occurrence_Of (Etyp, Loc), |
| Name => Expr)); |
| |
| if Variable then |
| |
| -- The name defined by the renaming declaration denotes a |
| -- constant view; create a non-constant object at the same address |
| -- to be used as the actual. |
| |
| declare |
| Constant_Object : constant Entity_Id := |
| Make_Temporary (Loc, 'P'); |
| |
| begin |
| Set_Defining_Identifier |
| (Last (Decls), Constant_Object); |
| |
| -- We have an unconstrained Etyp: build the actual constrained |
| -- subtype for the value we just read from the stream. |
| |
| -- subtype S is <actual subtype of Constant_Object>; |
| |
| Append_To (Decls, |
| Build_Actual_Subtype (Etyp, |
| New_Occurrence_Of (Constant_Object, Loc))); |
| |
| -- Object : S; |
| |
| Append_To (Decls, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Object, |
| Object_Definition => |
| New_Occurrence_Of |
| (Defining_Identifier (Last (Decls)), Loc))); |
| Set_Ekind (Object, E_Variable); |
| |
| -- Suppress default initialization: |
| -- pragma Import (Ada, Object); |
| |
| Append_To (Decls, |
| Make_Pragma (Loc, |
| Chars => Name_Import, |
| Pragma_Argument_Associations => New_List ( |
| Make_Pragma_Argument_Association (Loc, |
| Chars => Name_Convention, |
| Expression => Make_Identifier (Loc, Name_Ada)), |
| Make_Pragma_Argument_Association (Loc, |
| Chars => Name_Entity, |
| Expression => New_Occurrence_Of (Object, Loc))))); |
| |
| -- for Object'Address use Constant_Object'Address; |
| |
| Append_To (Decls, |
| Make_Attribute_Definition_Clause (Loc, |
| Name => New_Occurrence_Of (Object, Loc), |
| Chars => Name_Address, |
| Expression => |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Occurrence_Of (Constant_Object, Loc), |
| Attribute_Name => Name_Address))); |
| end; |
| end if; |
| |
| else |
| -- General case of a regular object declaration. Object is flagged |
| -- constant unless it has mode out or in out, to allow the backend |
| -- to optimize where possible. |
| |
| -- Object : [constant] Etyp [:= <expr>]; |
| |
| Append_To (Decls, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Object, |
| Constant_Present => Present (Expr) and then not Variable, |
| Object_Definition => New_Occurrence_Of (Etyp, Loc), |
| Expression => Expr)); |
| |
| if Constant_Present (Last (Decls)) then |
| Set_Ekind (Object, E_Constant); |
| else |
| Set_Ekind (Object, E_Variable); |
| end if; |
| end if; |
| end Build_Actual_Object_Declaration; |
| |
| ------------------------------ |
| -- Build_Get_Unique_RP_Call -- |
| ------------------------------ |
| |
| function Build_Get_Unique_RP_Call |
| (Loc : Source_Ptr; |
| Pointer : Entity_Id; |
| Stub_Type : Entity_Id) return List_Id |
| is |
| begin |
| return New_List ( |
| Make_Procedure_Call_Statement (Loc, |
| Name => |
| New_Occurrence_Of (RTE (RE_Get_Unique_Remote_Pointer), Loc), |
| Parameter_Associations => New_List ( |
| Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access), |
| New_Occurrence_Of (Pointer, Loc)))), |
| |
| Make_Assignment_Statement (Loc, |
| Name => |
| Make_Selected_Component (Loc, |
| Prefix => New_Occurrence_Of (Pointer, Loc), |
| Selector_Name => |
| New_Occurrence_Of (First_Tag_Component |
| (Designated_Type (Etype (Pointer))), Loc)), |
| Expression => |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Occurrence_Of (Stub_Type, Loc), |
| Attribute_Name => Name_Tag))); |
| |
| -- Note: The assignment to Pointer._Tag is safe here because |
| -- we carefully ensured that Stub_Type has exactly the same layout |
| -- as System.Partition_Interface.RACW_Stub_Type. |
| |
| end Build_Get_Unique_RP_Call; |
| |
| ----------------------------------- |
| -- Build_Ordered_Parameters_List -- |
| ----------------------------------- |
| |
| function Build_Ordered_Parameters_List (Spec : Node_Id) return List_Id is |
| Constrained_List : List_Id; |
| Unconstrained_List : List_Id; |
| Current_Parameter : Node_Id; |
| Ptyp : Node_Id; |
| |
| First_Parameter : Node_Id; |
| For_RAS : Boolean := False; |
| |
| begin |
| if No (Parameter_Specifications (Spec)) then |
| return New_List; |
| end if; |
| |
| Constrained_List := New_List; |
| Unconstrained_List := New_List; |
| First_Parameter := First (Parameter_Specifications (Spec)); |
| |
| if Nkind (Parameter_Type (First_Parameter)) = N_Access_Definition |
| and then Chars (Defining_Identifier (First_Parameter)) = Name_uS |
| then |
| For_RAS := True; |
| end if; |
| |
| -- Loop through the parameters and add them to the right list. Note that |
| -- we treat a parameter of a null-excluding access type as unconstrained |
| -- because we can't declare an object of such a type with default |
| -- initialization. |
| |
| Current_Parameter := First_Parameter; |
| while Present (Current_Parameter) loop |
| Ptyp := Parameter_Type (Current_Parameter); |
| |
| if (Nkind (Ptyp) = N_Access_Definition |
| or else not Transmit_As_Unconstrained (Etype (Ptyp))) |
| and then not (For_RAS and then Current_Parameter = First_Parameter) |
| then |
| Append_To (Constrained_List, New_Copy (Current_Parameter)); |
| else |
| Append_To (Unconstrained_List, New_Copy (Current_Parameter)); |
| end if; |
| |
| Next (Current_Parameter); |
| end loop; |
| |
| -- Unconstrained parameters are returned first |
| |
| Append_List_To (Unconstrained_List, Constrained_List); |
| |
| return Unconstrained_List; |
| end Build_Ordered_Parameters_List; |
| |
| ---------------------------------- |
| -- Build_Passive_Partition_Stub -- |
| ---------------------------------- |
| |
| procedure Build_Passive_Partition_Stub (U : Node_Id) is |
| Pkg_Spec : Node_Id; |
| Pkg_Ent : Entity_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; |
| Pkg_Ent := Defining_Entity (Pkg_Spec); |
| |
| Reg := |
| Make_Procedure_Call_Statement (Loc, |
| Name => |
| New_Occurrence_Of (RTE (RE_Register_Passive_Package), Loc), |
| Parameter_Associations => New_List ( |
| Make_String_Literal (Loc, |
| Fully_Qualified_Name_String (Pkg_Ent, Append_NUL => False)), |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Occurrence_Of (Pkg_Ent, Loc), |
| Attribute_Name => Name_Version))); |
| Append_To (L, Reg); |
| Analyze (Reg); |
| end Build_Passive_Partition_Stub; |
| |
| -------------------------------------- |
| -- Build_RPC_Receiver_Specification -- |
| -------------------------------------- |
| |
| function Build_RPC_Receiver_Specification |
| (RPC_Receiver : Entity_Id; |
| Request_Parameter : Entity_Id) return Node_Id |
| is |
| Loc : constant Source_Ptr := Sloc (RPC_Receiver); |
| begin |
| return |
| Make_Procedure_Specification (Loc, |
| Defining_Unit_Name => RPC_Receiver, |
| Parameter_Specifications => New_List ( |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => Request_Parameter, |
| Parameter_Type => |
| New_Occurrence_Of (RTE (RE_Request_Access), Loc)))); |
| end Build_RPC_Receiver_Specification; |
| |
| ---------------------------------------- |
| -- Build_Remote_Subprogram_Proxy_Type -- |
| ---------------------------------------- |
| |
| function Build_Remote_Subprogram_Proxy_Type |
| (Loc : Source_Ptr; |
| ACR_Expression : Node_Id) return Node_Id |
| is |
| begin |
| return |
| Make_Record_Definition (Loc, |
| Tagged_Present => True, |
| Limited_Present => True, |
| Component_List => |
| Make_Component_List (Loc, |
| Component_Items => New_List ( |
| Make_Component_Declaration (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, |
| Name_All_Calls_Remote), |
| Component_Definition => |
| Make_Component_Definition (Loc, |
| Subtype_Indication => |
| New_Occurrence_Of (Standard_Boolean, Loc)), |
| Expression => |
| ACR_Expression), |
| |
| Make_Component_Declaration (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, |
| Name_Receiver), |
| Component_Definition => |
| Make_Component_Definition (Loc, |
| Subtype_Indication => |
| New_Occurrence_Of (RTE (RE_Address), Loc)), |
| Expression => |
| New_Occurrence_Of (RTE (RE_Null_Address), Loc)), |
| |
| Make_Component_Declaration (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, |
| Name_Subp_Id), |
| Component_Definition => |
| Make_Component_Definition (Loc, |
| Subtype_Indication => |
| New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc)))))); |
| end Build_Remote_Subprogram_Proxy_Type; |
| |
| -------------------- |
| -- Build_Stub_Tag -- |
| -------------------- |
| |
| function Build_Stub_Tag |
| (Loc : Source_Ptr; |
| RACW_Type : Entity_Id) return Node_Id |
| is |
| Stub_Type : constant Entity_Id := Corresponding_Stub_Type (RACW_Type); |
| begin |
| return |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Occurrence_Of (Stub_Type, Loc), |
| Attribute_Name => Name_Tag); |
| end Build_Stub_Tag; |
| |
| ------------------------------------ |
| -- Build_Subprogram_Calling_Stubs -- |
| ------------------------------------ |
| |
| function Build_Subprogram_Calling_Stubs |
| (Vis_Decl : Node_Id; |
| Subp_Id : Node_Id; |
| Asynchronous : Boolean; |
| Dynamically_Asynchronous : Boolean := False; |
| Stub_Type : Entity_Id := Empty; |
| RACW_Type : Entity_Id := Empty; |
| Locator : Entity_Id := Empty; |
| New_Name : Name_Id := No_Name) return Node_Id |
| is |
| Loc : constant Source_Ptr := Sloc (Vis_Decl); |
| |
| Decls : constant List_Id := New_List; |
| Statements : constant List_Id := New_List; |
| |
| Subp_Spec : Node_Id; |
| -- The specification of the body |
| |
| Controlling_Parameter : Entity_Id := Empty; |
| |
| Asynchronous_Expr : Node_Id := Empty; |
| |
| RCI_Locator : Entity_Id; |
| |
| Spec_To_Use : Node_Id; |
| |
| procedure Insert_Partition_Check (Parameter : Node_Id); |
| -- Check that the parameter has been elaborated on the same partition |
| -- than the controlling parameter (E.4(19)). |
| |
| ---------------------------- |
| -- Insert_Partition_Check -- |
| ---------------------------- |
| |
| procedure Insert_Partition_Check (Parameter : Node_Id) is |
| Parameter_Entity : constant Entity_Id := |
| Defining_Identifier (Parameter); |
| begin |
| -- The expression that will be built is of the form: |
| |
| -- if not Same_Partition (Parameter, Controlling_Parameter) then |
| -- raise Constraint_Error; |
| -- end if; |
| |
| -- We do not check that Parameter is in Stub_Type since such a check |
| -- has been inserted at the point of call already (a tag check since |
| -- we have multiple controlling operands). |
| |
| Append_To (Decls, |
| Make_Raise_Constraint_Error (Loc, |
| Condition => |
| Make_Op_Not (Loc, |
| Right_Opnd => |
| Make_Function_Call (Loc, |
| Name => |
| New_Occurrence_Of (RTE (RE_Same_Partition), Loc), |
| Parameter_Associations => |
| New_List ( |
| Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access), |
| New_Occurrence_Of (Parameter_Entity, Loc)), |
| Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access), |
| New_Occurrence_Of (Controlling_Parameter, Loc))))), |
| Reason => CE_Partition_Check_Failed)); |
| end Insert_Partition_Check; |
| |
| -- Start of processing for Build_Subprogram_Calling_Stubs |
| |
| begin |
| Subp_Spec := |
| Copy_Specification (Loc, |
| Spec => Specification (Vis_Decl), |
| New_Name => New_Name); |
| |
| if Locator = Empty then |
| RCI_Locator := RCI_Cache; |
| Spec_To_Use := Specification (Vis_Decl); |
| else |
| RCI_Locator := Locator; |
| Spec_To_Use := Subp_Spec; |
| end if; |
| |
| -- Find a controlling argument if we have a stub type. Also check |
| -- if this subprogram can be made asynchronous. |
| |
| if Present (Stub_Type) |
| and then Present (Parameter_Specifications (Spec_To_Use)) |
| then |
| declare |
| Current_Parameter : Node_Id := |
| First (Parameter_Specifications |
| (Spec_To_Use)); |
| begin |
| while Present (Current_Parameter) loop |
| if |
| Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type) |
| then |
| if Controlling_Parameter = Empty then |
| Controlling_Parameter := |
| Defining_Identifier (Current_Parameter); |
| else |
| Insert_Partition_Check (Current_Parameter); |
| end if; |
| end if; |
| |
| Next (Current_Parameter); |
| end loop; |
| end; |
| end if; |
| |
| pragma Assert (No (Stub_Type) or else Present (Controlling_Parameter)); |
| |
| if Dynamically_Asynchronous then |
| Asynchronous_Expr := Make_Selected_Component (Loc, |
| Prefix => Controlling_Parameter, |
| Selector_Name => Name_Asynchronous); |
| end if; |
| |
| Specific_Build_General_Calling_Stubs |
| (Decls => Decls, |
| Statements => Statements, |
| Target => Specific_Build_Stub_Target (Loc, |
| Decls, RCI_Locator, Controlling_Parameter), |
| Subprogram_Id => Subp_Id, |
| Asynchronous => Asynchronous_Expr, |
| Is_Known_Asynchronous => Asynchronous |
| and then not Dynamically_Asynchronous, |
| Is_Known_Non_Asynchronous |
| => not Asynchronous |
| and then not Dynamically_Asynchronous, |
| Is_Function => Nkind (Spec_To_Use) = |
| N_Function_Specification, |
| Spec => Spec_To_Use, |
| Stub_Type => Stub_Type, |
| RACW_Type => RACW_Type, |
| Nod => Vis_Decl); |
| |
| RCI_Calling_Stubs_Table.Set |
| (Defining_Unit_Name (Specification (Vis_Decl)), |
| Defining_Unit_Name (Spec_To_Use)); |
| |
| return |
| Make_Subprogram_Body (Loc, |
| Specification => Subp_Spec, |
| Declarations => Decls, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, Statements)); |
| end Build_Subprogram_Calling_Stubs; |
| |
| ------------------------- |
| -- Build_Subprogram_Id -- |
| ------------------------- |
| |
| function Build_Subprogram_Id |
| (Loc : Source_Ptr; |
| E : Entity_Id) return Node_Id |
| is |
| begin |
| if Get_Subprogram_Ids (E).Str_Identifier = No_String then |
| declare |
| Current_Declaration : Node_Id; |
| Current_Subp : Entity_Id; |
| Current_Subp_Str : String_Id; |
| Current_Subp_Number : Int := First_RCI_Subprogram_Id; |
| |
| pragma Warnings (Off, Current_Subp_Str); |
| |
| begin |
| -- Build_Subprogram_Id is called outside of the context of |
| -- generating calling or receiving stubs. Hence we are processing |
| -- an 'Access attribute_reference for an RCI subprogram, for the |
| -- purpose of obtaining a RAS value. |
| |
| pragma Assert |
| (Is_Remote_Call_Interface (Scope (E)) |
| and then |
| (Nkind (Parent (E)) = N_Procedure_Specification |
| or else |
| Nkind (Parent (E)) = N_Function_Specification)); |
| |
| Current_Declaration := |
| First (Visible_Declarations |
| (Package_Specification_Of_Scope (Scope (E)))); |
| while Present (Current_Declaration) loop |
| if Nkind (Current_Declaration) = N_Subprogram_Declaration |
| and then Comes_From_Source (Current_Declaration) |
| then |
| Current_Subp := Defining_Unit_Name (Specification ( |
| Current_Declaration)); |
| |
| Assign_Subprogram_Identifier |
| (Current_Subp, Current_Subp_Number, Current_Subp_Str); |
| |
| Current_Subp_Number := Current_Subp_Number + 1; |
| end if; |
| |
| Next (Current_Declaration); |
| end loop; |
| end; |
| end if; |
| |
| case Get_PCS_Name is |
| when Name_PolyORB_DSA => |
| return Make_String_Literal (Loc, Get_Subprogram_Id (E)); |
| when others => |
| return Make_Integer_Literal (Loc, Get_Subprogram_Id (E)); |
| end case; |
| end Build_Subprogram_Id; |
| |
| ------------------------ |
| -- Copy_Specification -- |
| ------------------------ |
| |
| function Copy_Specification |
| (Loc : Source_Ptr; |
| Spec : Node_Id; |
| Ctrl_Type : Entity_Id := Empty; |
| New_Name : Name_Id := No_Name) return Node_Id |
| is |
| Parameters : List_Id := No_List; |
| |
| Current_Parameter : Node_Id; |
| Current_Identifier : Entity_Id; |
| Current_Type : Node_Id; |
| |
| Name_For_New_Spec : Name_Id; |
| |
| New_Identifier : Entity_Id; |
| |
| -- Comments needed in body below ??? |
| |
| begin |
| if New_Name = No_Name then |
| pragma Assert (Nkind (Spec) = N_Function_Specification |
| or else Nkind (Spec) = N_Procedure_Specification); |
| |
| Name_For_New_Spec := Chars (Defining_Unit_Name (Spec)); |
| else |
| Name_For_New_Spec := New_Name; |
| end if; |
| |
| if Present (Parameter_Specifications (Spec)) then |
| Parameters := New_List; |
| Current_Parameter := First (Parameter_Specifications (Spec)); |
| while Present (Current_Parameter) loop |
| Current_Identifier := Defining_Identifier (Current_Parameter); |
| Current_Type := Parameter_Type (Current_Parameter); |
| |
| if Nkind (Current_Type) = N_Access_Definition then |
| if Present (Ctrl_Type) then |
| pragma Assert (Is_Controlling_Formal (Current_Identifier)); |
| Current_Type := |
| Make_Access_Definition (Loc, |
| Subtype_Mark => New_Occurrence_Of (Ctrl_Type, Loc), |
| Null_Exclusion_Present => |
| Null_Exclusion_Present (Current_Type)); |
| |
| else |
| Current_Type := |
| Make_Access_Definition (Loc, |
| Subtype_Mark => |
| New_Copy_Tree (Subtype_Mark (Current_Type)), |
| Null_Exclusion_Present => |
| Null_Exclusion_Present (Current_Type)); |
| end if; |
| |
| else |
| if Present (Ctrl_Type) |
| and then Is_Controlling_Formal (Current_Identifier) |
| then |
| Current_Type := New_Occurrence_Of (Ctrl_Type, Loc); |
| else |
| Current_Type := New_Copy_Tree (Current_Type); |
| end if; |
| end if; |
| |
| New_Identifier := Make_Defining_Identifier (Loc, |
| Chars (Current_Identifier)); |
| |
| Append_To (Parameters, |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => New_Identifier, |
| Parameter_Type => Current_Type, |
| In_Present => In_Present (Current_Parameter), |
| Out_Present => Out_Present (Current_Parameter), |
| Expression => |
| New_Copy_Tree (Expression (Current_Parameter)))); |
| |
| -- For a regular formal parameter (that needs to be marshalled |
| -- in the context of remote calls), set the Etype now, because |
| -- marshalling processing might need it. |
| |
| if Is_Entity_Name (Current_Type) then |
| Set_Etype (New_Identifier, Entity (Current_Type)); |
| |
| -- Current_Type is an access definition, special processing |
| -- (not requiring etype) will occur for marshalling. |
| |
| else |
| null; |
| end if; |
| |
| Next (Current_Parameter); |
| end loop; |
| end if; |
| |
| case Nkind (Spec) is |
| |
| when N_Function_Specification | N_Access_Function_Definition => |
| return |
| Make_Function_Specification (Loc, |
| Defining_Unit_Name => |
| Make_Defining_Identifier (Loc, |
| Chars => Name_For_New_Spec), |
| Parameter_Specifications => Parameters, |
| Result_Definition => |
| New_Occurrence_Of (Entity (Result_Definition (Spec)), Loc)); |
| |
| when N_Procedure_Specification | N_Access_Procedure_Definition => |
| return |
| Make_Procedure_Specification (Loc, |
| Defining_Unit_Name => |
| Make_Defining_Identifier (Loc, |
| Chars => Name_For_New_Spec), |
| Parameter_Specifications => Parameters); |
| |
| when others => |
| raise Program_Error; |
| end case; |
| end Copy_Specification; |
| |
| ----------------------------- |
| -- Corresponding_Stub_Type -- |
| ----------------------------- |
| |
| function Corresponding_Stub_Type (RACW_Type : Entity_Id) return Entity_Id is |
| Desig : constant Entity_Id := |
| Etype (Designated_Type (RACW_Type)); |
| Stub_Elements : constant Stub_Structure := Stubs_Table.Get (Desig); |
| begin |
| return Stub_Elements.Stub_Type; |
| end Corresponding_Stub_Type; |
| |
| --------------------------- |
| -- Could_Be_Asynchronous -- |
| --------------------------- |
| |
| function Could_Be_Asynchronous (Spec : Node_Id) return Boolean is |
| Current_Parameter : Node_Id; |
| |
| begin |
| if Present (Parameter_Specifications (Spec)) then |
| Current_Parameter := First (Parameter_Specifications (Spec)); |
| while Present (Current_Parameter) loop |
| if Out_Present (Current_Parameter) then |
| return False; |
| end if; |
| |
| Next (Current_Parameter); |
| end loop; |
| end if; |
| |
| return True; |
| end Could_Be_Asynchronous; |
| |
| --------------------------- |
| -- Declare_Create_NVList -- |
| --------------------------- |
| |
| procedure Declare_Create_NVList |
| (Loc : Source_Ptr; |
| NVList : Entity_Id; |
| Decls : List_Id; |
| Stmts : List_Id) |
| is |
| begin |
| Append_To (Decls, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => NVList, |
| Aliased_Present => False, |
| Object_Definition => |
| New_Occurrence_Of (RTE (RE_NVList_Ref), Loc))); |
| |
| Append_To (Stmts, |
| Make_Procedure_Call_Statement (Loc, |
| Name => New_Occurrence_Of (RTE (RE_NVList_Create), Loc), |
| Parameter_Associations => New_List ( |
| New_Occurrence_Of (NVList, Loc)))); |
| end Declare_Create_NVList; |
| |
| --------------------------------------------- |
| -- Expand_All_Calls_Remote_Subprogram_Call -- |
| --------------------------------------------- |
| |
| procedure Expand_All_Calls_Remote_Subprogram_Call (N : Node_Id) is |
| Loc : constant Source_Ptr := Sloc (N); |
| Called_Subprogram : constant Entity_Id := Entity (Name (N)); |
| RCI_Package : constant Entity_Id := Scope (Called_Subprogram); |
| RCI_Locator_Decl : Node_Id; |
| RCI_Locator : Entity_Id; |
| Calling_Stubs : Node_Id; |
| E_Calling_Stubs : Entity_Id; |
| |
| begin |
| E_Calling_Stubs := RCI_Calling_Stubs_Table.Get (Called_Subprogram); |
| |
| if E_Calling_Stubs = Empty then |
| RCI_Locator := RCI_Locator_Table.Get (RCI_Package); |
| |
| -- The RCI_Locator package and calling stub are is inserted at the |
| -- top level in the current unit, and must appear in the proper scope |
| -- so that it is not prematurely removed by the GCC back end. |
| |
| declare |
| Scop : constant Entity_Id := Cunit_Entity (Current_Sem_Unit); |
| begin |
| if Ekind (Scop) = E_Package_Body then |
| Push_Scope (Spec_Entity (Scop)); |
| elsif Ekind (Scop) = E_Subprogram_Body then |
| Push_Scope |
| (Corresponding_Spec (Unit_Declaration_Node (Scop))); |
| else |
| Push_Scope (Scop); |
| end if; |
| end; |
| |
| if RCI_Locator = Empty then |
| RCI_Locator_Decl := |
| RCI_Package_Locator (Loc, Package_Specification (RCI_Package)); |
| Prepend_To (Current_Sem_Unit_Declarations, RCI_Locator_Decl); |
| Analyze (RCI_Locator_Decl); |
| RCI_Locator := Defining_Unit_Name (RCI_Locator_Decl); |
| |
| else |
| RCI_Locator_Decl := Parent (RCI_Locator); |
| end if; |
| |
| Calling_Stubs := Build_Subprogram_Calling_Stubs |
| (Vis_Decl => Parent (Parent (Called_Subprogram)), |
| Subp_Id => |
| Build_Subprogram_Id (Loc, Called_Subprogram), |
| Asynchronous => Nkind (N) = N_Procedure_Call_Statement |
| and then |
| Is_Asynchronous (Called_Subprogram), |
| Locator => RCI_Locator, |
| New_Name => New_Internal_Name ('S')); |
| Insert_After (RCI_Locator_Decl, Calling_Stubs); |
| Analyze (Calling_Stubs); |
| Pop_Scope; |
| |
| E_Calling_Stubs := Defining_Unit_Name (Specification (Calling_Stubs)); |
| end if; |
| |
| Rewrite (Name (N), New_Occurrence_Of (E_Calling_Stubs, Loc)); |
| end Expand_All_Calls_Remote_Subprogram_Call; |
| |
| --------------------------------- |
| -- Expand_Calling_Stubs_Bodies -- |
| --------------------------------- |
| |
| procedure Expand_Calling_Stubs_Bodies (Unit_Node : Node_Id) is |
| Spec : constant Node_Id := Specification (Unit_Node); |
| begin |
| Add_Calling_Stubs_To_Declarations (Spec); |
| end Expand_Calling_Stubs_Bodies; |
| |
| ----------------------------------- |
| -- Expand_Receiving_Stubs_Bodies -- |
| ----------------------------------- |
| |
| procedure Expand_Receiving_Stubs_Bodies (Unit_Node : Node_Id) is |
| Spec : Node_Id; |
| Decls : List_Id; |
| Stubs_Decls : List_Id; |
| Stubs_Stmts : List_Id; |
| |
| begin |
| if Nkind (Unit_Node) = N_Package_Declaration then |
| Spec := Specification (Unit_Node); |
| Decls := Private_Declarations (Spec); |
| |
| if No (Decls) then |
| Decls := Visible_Declarations (Spec); |
| end if; |
| |
| Push_Scope (Scope_Of_Spec (Spec)); |
| Specific_Add_Receiving_Stubs_To_Declarations (Spec, Decls, Decls); |
| |
| else |
| Spec := |
| Package_Specification_Of_Scope (Corresponding_Spec (Unit_Node)); |
| Decls := Declarations (Unit_Node); |
| |
| Push_Scope (Scope_Of_Spec (Unit_Node)); |
| Stubs_Decls := New_List; |
| Stubs_Stmts := New_List; |
| Specific_Add_Receiving_Stubs_To_Declarations |
| (Spec, Stubs_Decls, Stubs_Stmts); |
| |
| Insert_List_Before (First (Decls), Stubs_Decls); |
| |
| declare |
| HSS_Stmts : constant List_Id := |
| Statements (Handled_Statement_Sequence (Unit_Node)); |
| |
| First_HSS_Stmt : constant Node_Id := First (HSS_Stmts); |
| |
| begin |
| if No (First_HSS_Stmt) then |
| Append_List_To (HSS_Stmts, Stubs_Stmts); |
| else |
| Insert_List_Before (First_HSS_Stmt, Stubs_Stmts); |
| end if; |
| end; |
| end if; |
| |
| Pop_Scope; |
| end Expand_Receiving_Stubs_Bodies; |
| |
| -------------------- |
| -- GARLIC_Support -- |
| -------------------- |
| |
| package body GARLIC_Support is |
| |
| -- Local subprograms |
| |
| procedure Add_RACW_Read_Attribute |
| (RACW_Type : Entity_Id; |
| Stub_Type : Entity_Id; |
| Stub_Type_Access : Entity_Id; |
| Body_Decls : List_Id); |
| -- Add Read attribute for the RACW type. The declaration and attribute |
| -- definition clauses are inserted right after the declaration of |
| -- RACW_Type. If Body_Decls is not No_List, the subprogram body is |
| -- appended to it (case where the RACW declaration is in the main unit). |
| |
| procedure Add_RACW_Write_Attribute |
| (RACW_Type : Entity_Id; |
| Stub_Type : Entity_Id; |
| Stub_Type_Access : Entity_Id; |
| RPC_Receiver : Node_Id; |
| Body_Decls : List_Id); |
| -- Same as above for the Write attribute |
| |
| function Stream_Parameter return Node_Id; |
| function Result return Node_Id; |
| function Object return Node_Id renames Result; |
| -- Functions to create occurrences of the formal parameter names of the |
| -- 'Read and 'Write attributes. |
| |
| Loc : Source_Ptr; |
| -- Shared source location used by Add_{Read,Write}_Read_Attribute and |
| -- their ancillary subroutines (set on entry by Add_RACW_Features). |
| |
| procedure Add_RAS_Access_TSS (N : Node_Id); |
| -- Add a subprogram body for RAS Access TSS |
| |
| ------------------------------------- |
| -- Add_Obj_RPC_Receiver_Completion -- |
| ------------------------------------- |
| |
| procedure Add_Obj_RPC_Receiver_Completion |
| (Loc : Source_Ptr; |
| Decls : List_Id; |
| RPC_Receiver : Entity_Id; |
| Stub_Elements : Stub_Structure) |
| is |
| begin |
| -- The RPC receiver body should not be the completion of the |
| -- declaration recorded in the stub structure, because then the |
| -- occurrences of the formal parameters within the body should refer |
| -- to the entities from the declaration, not from the completion, to |
| -- which we do not have easy access. Instead, the RPC receiver body |
| -- acts as its own declaration, and the RPC receiver declaration is |
| -- completed by a renaming-as-body. |
| |
| Append_To (Decls, |
| Make_Subprogram_Renaming_Declaration (Loc, |
| Specification => |
| Copy_Specification (Loc, |
| Specification (Stub_Elements.RPC_Receiver_Decl)), |
| Name => New_Occurrence_Of (RPC_Receiver, Loc))); |
| end Add_Obj_RPC_Receiver_Completion; |
| |
| ----------------------- |
| -- Add_RACW_Features -- |
| ----------------------- |
| |
| procedure Add_RACW_Features |
| (RACW_Type : Entity_Id; |
| Stub_Type : Entity_Id; |
| Stub_Type_Access : Entity_Id; |
| RPC_Receiver_Decl : Node_Id; |
| Body_Decls : List_Id) |
| is |
| RPC_Receiver : Node_Id; |
| Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type); |
| |
| begin |
| Loc := Sloc (RACW_Type); |
| |
| if Is_RAS then |
| |
| -- For a RAS, the RPC receiver is that of the RCI unit, not that |
| -- of the corresponding distributed object type. We retrieve its |
| -- address from the local proxy object. |
| |
| RPC_Receiver := Make_Selected_Component (Loc, |
| Prefix => |
| Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access), Object), |
| Selector_Name => Make_Identifier (Loc, Name_Receiver)); |
| |
| else |
| RPC_Receiver := Make_Attribute_Reference (Loc, |
| Prefix => New_Occurrence_Of ( |
| Defining_Unit_Name (Specification (RPC_Receiver_Decl)), Loc), |
| Attribute_Name => Name_Address); |
| end if; |
| |
| Add_RACW_Write_Attribute |
| (RACW_Type, |
| Stub_Type, |
| Stub_Type_Access, |
| RPC_Receiver, |
| Body_Decls); |
| |
| Add_RACW_Read_Attribute |
| (RACW_Type, |
| Stub_Type, |
| Stub_Type_Access, |
| Body_Decls); |
| end Add_RACW_Features; |
| |
| ----------------------------- |
| -- Add_RACW_Read_Attribute -- |
| ----------------------------- |
| |
| procedure Add_RACW_Read_Attribute |
| (RACW_Type : Entity_Id; |
| Stub_Type : Entity_Id; |
| Stub_Type_Access : Entity_Id; |
| Body_Decls : List_Id) |
| is |
| Proc_Decl : Node_Id; |
| Attr_Decl : Node_Id; |
| |
| Body_Node : Node_Id; |
| |
| Statements : constant List_Id := New_List; |
| Decls : List_Id; |
| Local_Statements : List_Id; |
| Remote_Statements : List_Id; |
| -- Various parts of the procedure |
| |
| Pnam : constant Entity_Id := Make_Temporary (Loc, 'R'); |
| Asynchronous_Flag : constant Entity_Id := |
| Asynchronous_Flags_Table.Get (RACW_Type); |
| pragma Assert (Present (Asynchronous_Flag)); |
| |
| -- Prepare local identifiers |
| |
| Source_Partition : Entity_Id; |
| Source_Receiver : Entity_Id; |
| Source_Address : Entity_Id; |
| Local_Stub : Entity_Id; |
| Stubbed_Result : Entity_Id; |
| |
| -- Start of processing for Add_RACW_Read_Attribute |
| |
| begin |
| Build_Stream_Procedure (Loc, |
| RACW_Type, Body_Node, Pnam, Statements, Outp => True); |
| Proc_Decl := Make_Subprogram_Declaration (Loc, |
| Copy_Specification (Loc, Specification (Body_Node))); |
| |
| Attr_Decl := |
| Make_Attribute_Definition_Clause (Loc, |
| Name => New_Occurrence_Of (RACW_Type, Loc), |
| Chars => Name_Read, |
| Expression => |
| New_Occurrence_Of ( |
| Defining_Unit_Name (Specification (Proc_Decl)), Loc)); |
| |
| Insert_After (Declaration_Node (RACW_Type), Proc_Decl); |
| Insert_After (Proc_Decl, Attr_Decl); |
| |
| if No (Body_Decls) then |
| |
| -- Case of processing an RACW type from another unit than the |
| -- main one: do not generate a body. |
| |
| return; |
| end if; |
| |
| -- Prepare local identifiers |
| |
| Source_Partition := Make_Temporary (Loc, 'P'); |
| Source_Receiver := Make_Temporary (Loc, 'S'); |
| Source_Address := Make_Temporary (Loc, 'P'); |
| Local_Stub := Make_Temporary (Loc, 'L'); |
| Stubbed_Result := Make_Temporary (Loc, 'S'); |
| |
| -- Generate object declarations |
| |
| Decls := New_List ( |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Source_Partition, |
| Object_Definition => |
| New_Occurrence_Of (RTE (RE_Partition_ID), Loc)), |
| |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Source_Receiver, |
| Object_Definition => |
| New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)), |
| |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Source_Address, |
| Object_Definition => |
| New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)), |
| |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Local_Stub, |
| Aliased_Present => True, |
| Object_Definition => New_Occurrence_Of (Stub_Type, Loc)), |
| |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Stubbed_Result, |
| Object_Definition => |
| New_Occurrence_Of (Stub_Type_Access, Loc), |
| Expression => |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| New_Occurrence_Of (Local_Stub, Loc), |
| Attribute_Name => |
| Name_Unchecked_Access))); |
| |
| -- Read the source Partition_ID and RPC_Receiver from incoming stream |
| |
| Append_List_To (Statements, New_List ( |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| New_Occurrence_Of (RTE (RE_Partition_ID), Loc), |
| Attribute_Name => Name_Read, |
| Expressions => New_List ( |
| Stream_Parameter, |
| New_Occurrence_Of (Source_Partition, Loc))), |
| |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| New_Occurrence_Of (RTE (RE_Unsigned_64), Loc), |
| Attribute_Name => |
| Name_Read, |
| Expressions => New_List ( |
| Stream_Parameter, |
| New_Occurrence_Of (Source_Receiver, Loc))), |
| |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| New_Occurrence_Of (RTE (RE_Unsigned_64), Loc), |
| Attribute_Name => |
| Name_Read, |
| Expressions => New_List ( |
| Stream_Parameter, |
| New_Occurrence_Of (Source_Address, Loc))))); |
| |
| -- Build_Get_Unique_RP_Call needs the type of Stubbed_Result |
| |
| Set_Etype (Stubbed_Result, Stub_Type_Access); |
| |
| -- If the Address is Null_Address, then return a null object, unless |
| -- RACW_Type is null-excluding, in which case unconditionally raise |
| -- CONSTRAINT_ERROR instead. |
| |
| declare |
| Zero_Statements : List_Id; |
| -- Statements executed when a zero value is received |
| |
| begin |
| if Can_Never_Be_Null (RACW_Type) then |
| Zero_Statements := New_List ( |
| Make_Raise_Constraint_Error (Loc, |
| Reason => CE_Null_Not_Allowed)); |
| else |
| Zero_Statements := New_List ( |
| Make_Assignment_Statement (Loc, |
| Name => Result, |
| Expression => Make_Null (Loc)), |
| Make_Simple_Return_Statement (Loc)); |
| end if; |
| |
| Append_To (Statements, |
| Make_Implicit_If_Statement (RACW_Type, |
| Condition => |
| Make_Op_Eq (Loc, |
| Left_Opnd => New_Occurrence_Of (Source_Address, Loc), |
| Right_Opnd => Make_Integer_Literal (Loc, Uint_0)), |
| Then_Statements => Zero_Statements)); |
| end; |
| |
| -- If the RACW denotes an object created on the current partition, |
| -- Local_Statements will be executed. The real object will be used. |
| |
| Local_Statements := New_List ( |
| Make_Assignment_Statement (Loc, |
| Name => Result, |
| Expression => |
| Unchecked_Convert_To (RACW_Type, |
| OK_Convert_To (RTE (RE_Address), |
| New_Occurrence_Of (Source_Address, Loc))))); |
| |
| -- If the object is located on another partition, then a stub object |
| -- will be created with all the information needed to rebuild the |
| -- real object at the other end. |
| |
| Remote_Statements := New_List ( |
| |
| Make_Assignment_Statement (Loc, |
| Name => Make_Selected_Component (Loc, |
| Prefix => Stubbed_Result, |
| Selector_Name => Name_Origin), |
| Expression => |
| New_Occurrence_Of (Source_Partition, Loc)), |
| |
| Make_Assignment_Statement (Loc, |
| Name => Make_Selected_Component (Loc, |
| Prefix => Stubbed_Result, |
| Selector_Name => Name_Receiver), |
| Expression => |
| New_Occurrence_Of (Source_Receiver, Loc)), |
| |
| Make_Assignment_Statement (Loc, |
| Name => Make_Selected_Component (Loc, |
| Prefix => Stubbed_Result, |
| Selector_Name => Name_Addr), |
| Expression => |
| New_Occurrence_Of (Source_Address, Loc))); |
| |
| Append_To (Remote_Statements, |
| Make_Assignment_Statement (Loc, |
| Name => Make_Selected_Component (Loc, |
| Prefix => Stubbed_Result, |
| Selector_Name => Name_Asynchronous), |
| Expression => |
| New_Occurrence_Of (Asynchronous_Flag, Loc))); |
| |
| Append_List_To (Remote_Statements, |
| Build_Get_Unique_RP_Call (Loc, Stubbed_Result, Stub_Type)); |
| -- ??? Issue with asynchronous calls here: the Asynchronous flag is |
| -- set on the stub type if, and only if, the RACW type has a pragma |
| -- Asynchronous. This is incorrect for RACWs that implement RAS |
| -- types, because in that case the /designated subprogram/ (not the |
| -- type) might be asynchronous, and that causes the stub to need to |
| -- be asynchronous too. A solution is to transport a RAS as a struct |
| -- containing a RACW and an asynchronous flag, and to properly alter |
| -- the Asynchronous component in the stub type in the RAS's Input |
| -- TSS. |
| |
| Append_To (Remote_Statements, |
| Make_Assignment_Statement (Loc, |
| Name => Result, |
| Expression => Unchecked_Convert_To (RACW_Type, |
| New_Occurrence_Of (Stubbed_Result, Loc)))); |
| |
| -- Distinguish between the local and remote cases, and execute the |
| -- appropriate piece of code. |
| |
| Append_To (Statements, |
| Make_Implicit_If_Statement (RACW_Type, |
| Condition => |
| Make_Op_Eq (Loc, |
| Left_Opnd => |
| Make_Function_Call (Loc, |
| Name => New_Occurrence_Of ( |
| RTE (RE_Get_Local_Partition_Id), Loc)), |
| Right_Opnd => New_Occurrence_Of (Source_Partition, Loc)), |
| Then_Statements => Local_Statements, |
| Else_Statements => Remote_Statements)); |
| |
| Set_Declarations (Body_Node, Decls); |
| Append_To (Body_Decls, Body_Node); |
| end Add_RACW_Read_Attribute; |
| |
| ------------------------------ |
| -- Add_RACW_Write_Attribute -- |
| ------------------------------ |
| |
| procedure Add_RACW_Write_Attribute |
| (RACW_Type : Entity_Id; |
| Stub_Type : Entity_Id; |
| Stub_Type_Access : Entity_Id; |
| RPC_Receiver : Node_Id; |
| Body_Decls : List_Id) |
| is |
| Body_Node : Node_Id; |
| Proc_Decl : Node_Id; |
| Attr_Decl : Node_Id; |
| |
| Statements : constant List_Id := New_List; |
| Local_Statements : List_Id; |
| Remote_Statements : List_Id; |
| Null_Statements : List_Id; |
| |
| Pnam : constant Entity_Id := Make_Temporary (Loc, 'R'); |
| |
| begin |
| Build_Stream_Procedure |
| (Loc, RACW_Type, Body_Node, Pnam, Statements, Outp => False); |
| |
| Proc_Decl := Make_Subprogram_Declaration (Loc, |
| Copy_Specification (Loc, Specification (Body_Node))); |
| |
| Attr_Decl := |
| Make_Attribute_Definition_Clause (Loc, |
| Name => New_Occurrence_Of (RACW_Type, Loc), |
| Chars => Name_Write, |
| Expression => |
| New_Occurrence_Of ( |
| Defining_Unit_Name (Specification (Proc_Decl)), Loc)); |
| |
| Insert_After (Declaration_Node (RACW_Type), Proc_Decl); |
| Insert_After (Proc_Decl, Attr_Decl); |
| |
| if No (Body_Decls) then |
| return; |
| end if; |
| |
| -- Build the code fragment corresponding to the marshalling of a |
| -- local object. |
| |
| Local_Statements := New_List ( |
| |
| Pack_Entity_Into_Stream_Access (Loc, |
| Stream => Stream_Parameter, |
| Object => RTE (RE_Get_Local_Partition_Id)), |
| |
| Pack_Node_Into_Stream_Access (Loc, |
| Stream => Stream_Parameter, |
| Object => OK_Convert_To (RTE (RE_Unsigned_64), RPC_Receiver), |
| Etyp => RTE (RE_Unsigned_64)), |
| |
| Pack_Node_Into_Stream_Access (Loc, |
| Stream => Stream_Parameter, |
| Object => OK_Convert_To (RTE (RE_Unsigned_64), |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| Make_Explicit_Dereference (Loc, |
| Prefix => Object), |
| Attribute_Name => Name_Address)), |
| Etyp => RTE (RE_Unsigned_64))); |
| |
| -- Build the code fragment corresponding to the marshalling of |
| -- a remote object. |
| |
| Remote_Statements := New_List ( |
| Pack_Node_Into_Stream_Access (Loc, |
| Stream => Stream_Parameter, |
| Object => |
| Make_Selected_Component (Loc, |
| Prefix => |
| Unchecked_Convert_To (Stub_Type_Access, Object), |
| Selector_Name => Make_Identifier (Loc, Name_Origin)), |
| Etyp => RTE (RE_Partition_ID)), |
| |
| Pack_Node_Into_Stream_Access (Loc, |
| Stream => Stream_Parameter, |
| Object => |
| Make_Selected_Component (Loc, |
| Prefix => |
| Unchecked_Convert_To (Stub_Type_Access, Object), |
| Selector_Name => Make_Identifier (Loc, Name_Receiver)), |
| Etyp => RTE (RE_Unsigned_64)), |
| |
| Pack_Node_Into_Stream_Access (Loc, |
| Stream => Stream_Parameter, |
| Object => |
| Make_Selected_Component (Loc, |
| Prefix => |
| Unchecked_Convert_To (Stub_Type_Access, Object), |
| Selector_Name => Make_Identifier (Loc, Name_Addr)), |
| Etyp => RTE (RE_Unsigned_64))); |
| |
| -- Build code fragment corresponding to marshalling of a null object |
| |
| Null_Statements := New_List ( |
| |
| Pack_Entity_Into_Stream_Access (Loc, |
| Stream => Stream_Parameter, |
| Object => RTE (RE_Get_Local_Partition_Id)), |
| |
| Pack_Node_Into_Stream_Access (Loc, |
| Stream => Stream_Parameter, |
| Object => OK_Convert_To (RTE (RE_Unsigned_64), RPC_Receiver), |
| Etyp => RTE (RE_Unsigned_64)), |
| |
| Pack_Node_Into_Stream_Access (Loc, |
| Stream => Stream_Parameter, |
| Object => Make_Integer_Literal (Loc, Uint_0), |
| Etyp => RTE (RE_Unsigned_64))); |
| |
| Append_To (Statements, |
| Make_Implicit_If_Statement (RACW_Type, |
| Condition => |
| Make_Op_Eq (Loc, |
| Left_Opnd => Object, |
| Right_Opnd => Make_Null (Loc)), |
| |
| Then_Statements => Null_Statements, |
| |
| Elsif_Parts => New_List ( |
| Make_Elsif_Part (Loc, |
| Condition => |
| Make_Op_Eq (Loc, |
| Left_Opnd => |
| Make_Attribute_Reference (Loc, |
| Prefix => Object, |
| Attribute_Name => Name_Tag), |
| |
| Right_Opnd => |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Occurrence_Of (Stub_Type, Loc), |
| Attribute_Name => Name_Tag)), |
| Then_Statements => Remote_Statements)), |
| Else_Statements => Local_Statements)); |
| |
| Append_To (Body_Decls, Body_Node); |
| end Add_RACW_Write_Attribute; |
| |
| ------------------------ |
| -- Add_RAS_Access_TSS -- |
| ------------------------ |
| |
| procedure Add_RAS_Access_TSS (N : Node_Id) is |
| Loc : constant Source_Ptr := Sloc (N); |
| |
| Ras_Type : constant Entity_Id := Defining_Identifier (N); |
| Fat_Type : constant Entity_Id := Equivalent_Type (Ras_Type); |
| -- Ras_Type is the access to subprogram type while Fat_Type is the |
| -- corresponding record type. |
| |
| RACW_Type : constant Entity_Id := |
| Underlying_RACW_Type (Ras_Type); |
| Desig : constant Entity_Id := |
| Etype (Designated_Type (RACW_Type)); |
| |
| Stub_Elements : constant Stub_Structure := |
| Stubs_Table.Get (Desig); |
| pragma Assert (Stub_Elements /= Empty_Stub_Structure); |
| |
| Proc : constant Entity_Id := |
| Make_Defining_Identifier (Loc, |
| Chars => Make_TSS_Name (Ras_Type, TSS_RAS_Access)); |
| |
| Proc_Spec : Node_Id; |
| |
| -- Formal parameters |
| |
| Package_Name : constant Entity_Id := |
| Make_Defining_Identifier (Loc, |
| Chars => Name_P); |
| -- Target package |
| |
| Subp_Id : constant Entity_Id := |
| Make_Defining_Identifier (Loc, |
| Chars => Name_S); |
| -- Target subprogram |
| |
| Asynch_P : constant Entity_Id := |
| Make_Defining_Identifier (Loc, |
| Chars => Name_Asynchronous); |
| -- Is the procedure to which the 'Access applies asynchronous? |
| |
| All_Calls_Remote : constant Entity_Id := |
| Make_Defining_Identifier (Loc, |
| Chars => Name_All_Calls_Remote); |
| -- True if an All_Calls_Remote pragma applies to the RCI unit |
| -- that contains the subprogram. |
| |
| -- Common local variables |
| |
| Proc_Decls : List_Id; |
| Proc_Statements : List_Id; |
| |
| Origin : constant Entity_Id := Make_Temporary (Loc, 'P'); |
| |
| -- Additional local variables for the local case |
| |
| Proxy_Addr : constant Entity_Id := Make_Temporary (Loc, 'P'); |
| |
| -- Additional local variables for the remote case |
| |
| Local_Stub : constant Entity_Id := Make_Temporary (Loc, 'L'); |
| Stub_Ptr : constant Entity_Id := Make_Temporary (Loc, 'S'); |
| |
| function Set_Field |
| (Field_Name : Name_Id; |
| Value : Node_Id) return Node_Id; |
| -- Construct an assignment that sets the named component in the |
| -- returned record |
| |
| --------------- |
| -- Set_Field -- |
| --------------- |
| |
| function Set_Field |
| (Field_Name : Name_Id; |
| Value : Node_Id) return Node_Id |
| is |
| begin |
| return |
| Make_Assignment_Statement (Loc, |
| Name => |
| Make_Selected_Component (Loc, |
| Prefix => Stub_Ptr, |
| Selector_Name => Field_Name), |
| Expression => Value); |
| end Set_Field; |
| |
| -- Start of processing for Add_RAS_Access_TSS |
| |
| begin |
| Proc_Decls := New_List ( |
| |
| -- Common declarations |
| |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Origin, |
| Constant_Present => True, |
| Object_Definition => |
| New_Occurrence_Of (RTE (RE_Partition_ID), Loc), |
| Expression => |
| Make_Function_Call (Loc, |
| Name => |
| New_Occurrence_Of (RTE (RE_Get_Active_Partition_Id), Loc), |
| Parameter_Associations => New_List ( |
| New_Occurrence_Of (Package_Name, Loc)))), |
| |
| -- Declaration use only in the local case: proxy address |
| |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Proxy_Addr, |
| Object_Definition => |
| New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)), |
| |
| -- Declarations used only in the remote case: stub object and |
| -- stub pointer. |
| |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Local_Stub, |
| Aliased_Present => True, |
| Object_Definition => |
| New_Occurrence_Of (Stub_Elements.Stub_Type, Loc)), |
| |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => |
| Stub_Ptr, |
| Object_Definition => |
| New_Occurrence_Of (Stub_Elements.Stub_Type_Access, Loc), |
| Expression => |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Occurrence_Of (Local_Stub, Loc), |
| Attribute_Name => Name_Unchecked_Access))); |
| |
| Set_Etype (Stub_Ptr, Stub_Elements.Stub_Type_Access); |
| |
| -- Build_Get_Unique_RP_Call needs above information |
| |
| -- Note: Here we assume that the Fat_Type is a record |
| -- containing just a pointer to a proxy or stub object. |
| |
| Proc_Statements := New_List ( |
| |
| -- Generate: |
| |
| -- Get_RAS_Info (Pkg, Subp, PA); |
| -- if Origin = Local_Partition_Id |
| -- and then not All_Calls_Remote |
| -- then |
| -- return Fat_Type!(PA); |
| -- end if; |
| |
| Make_Procedure_Call_Statement (Loc, |
| Name => New_Occurrence_Of (RTE (RE_Get_RAS_Info), Loc), |
| Parameter_Associations => New_List ( |
| New_Occurrence_Of (Package_Name, Loc), |
| New_Occurrence_Of (Subp_Id, Loc), |
| New_Occurrence_Of (Proxy_Addr, Loc))), |
| |
| Make_Implicit_If_Statement (N, |
| Condition => |
| Make_And_Then (Loc, |
| Left_Opnd => |
| Make_Op_Eq (Loc, |
| Left_Opnd => |
| New_Occurrence_Of (Origin, Loc), |
| Right_Opnd => |
| Make_Function_Call (Loc, |
| New_Occurrence_Of ( |
| RTE (RE_Get_Local_Partition_Id), Loc))), |
| |
| Right_Opnd => |
| Make_Op_Not (Loc, |
| New_Occurrence_Of (All_Calls_Remote, Loc))), |
| |
| Then_Statements => New_List ( |
| Make_Simple_Return_Statement (Loc, |
| Unchecked_Convert_To (Fat_Type, |
| OK_Convert_To (RTE (RE_Address), |
| New_Occurrence_Of (Proxy_Addr, Loc)))))), |
| |
| Set_Field (Name_Origin, |
| New_Occurrence_Of (Origin, Loc)), |
| |
| Set_Field (Name_Receiver, |
| Make_Function_Call (Loc, |
| Name => |
| New_Occurrence_Of (RTE (RE_Get_RCI_Package_Receiver), Loc), |
| Parameter_Associations => New_List ( |
| New_Occurrence_Of (Package_Name, Loc)))), |
| |
| Set_Field (Name_Addr, New_Occurrence_Of (Proxy_Addr, Loc)), |
| |
| -- E.4.1(9) A remote call is asynchronous if it is a call to |
| -- a procedure or a call through a value of an access-to-procedure |
| -- type to which a pragma Asynchronous applies. |
| |
| -- Asynch_P is true when the procedure is asynchronous; |
| -- Asynch_T is true when the type is asynchronous. |
| |
| Set_Field (Name_Asynchronous, |
| Make_Or_Else (Loc, |
| New_Occurrence_Of (Asynch_P, Loc), |
| New_Occurrence_Of (Boolean_Literals ( |
| Is_Asynchronous (Ras_Type)), Loc)))); |
| |
| Append_List_To (Proc_Statements, |
| Build_Get_Unique_RP_Call |
| (Loc, Stub_Ptr, Stub_Elements.Stub_Type)); |
| |
| -- Return the newly created value |
| |
| Append_To (Proc_Statements, |
| Make_Simple_Return_Statement (Loc, |
| Expression => |
| Unchecked_Convert_To (Fat_Type, |
| New_Occurrence_Of (Stub_Ptr, Loc)))); |
| |
| Proc_Spec := |
| Make_Function_Specification (Loc, |
| Defining_Unit_Name => Proc, |
| Parameter_Specifications => New_List ( |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => Package_Name, |
| Parameter_Type => |
| New_Occurrence_Of (Standard_String, Loc)), |
| |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => Subp_Id, |
| Parameter_Type => |
| New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc)), |
| |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => Asynch_P, |
| Parameter_Type => |
| New_Occurrence_Of (Standard_Boolean, Loc)), |
| |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => All_Calls_Remote, |
| Parameter_Type => |
| New_Occurrence_Of (Standard_Boolean, Loc))), |
| |
| Result_Definition => |
| New_Occurrence_Of (Fat_Type, Loc)); |
| |
| -- Set the kind and return type of the function to prevent |
| -- ambiguities between Ras_Type and Fat_Type in subsequent analysis. |
| |
| Set_Ekind (Proc, E_Function); |
| Set_Etype (Proc, Fat_Type); |
| |
| Discard_Node ( |
| Make_Subprogram_Body (Loc, |
| Specification => Proc_Spec, |
| Declarations => Proc_Decls, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => Proc_Statements))); |
| |
| Set_TSS (Fat_Type, Proc); |
| end Add_RAS_Access_TSS; |
| |
| ----------------------- |
| -- Add_RAST_Features -- |
| ----------------------- |
| |
| procedure Add_RAST_Features |
| (Vis_Decl : Node_Id; |
| RAS_Type : Entity_Id) |
| is |
| pragma Unreferenced (RAS_Type); |
| begin |
| Add_RAS_Access_TSS (Vis_Decl); |
| end Add_RAST_Features; |
| |
| ----------------------------------------- |
| -- Add_Receiving_Stubs_To_Declarations -- |
| ----------------------------------------- |
| |
| procedure Add_Receiving_Stubs_To_Declarations |
| (Pkg_Spec : Node_Id; |
| Decls : List_Id; |
| Stmts : List_Id) |
| is |
| Loc : constant Source_Ptr := Sloc (Pkg_Spec); |
| |
| Request_Parameter : Node_Id; |
| |
| Pkg_RPC_Receiver : constant Entity_Id := |
| Make_Temporary (Loc, 'H'); |
| Pkg_RPC_Receiver_Statements : List_Id; |
| Pkg_RPC_Receiver_Cases : constant List_Id := New_List; |
| Pkg_RPC_Receiver_Body : Node_Id; |
| -- A Pkg_RPC_Receiver is built to decode the request |
| |
| Lookup_RAS : Node_Id; |
| Lookup_RAS_Info : constant Entity_Id := Make_Temporary (Loc, 'R'); |
| -- A remote subprogram is created to allow peers to look up RAS |
| -- information using subprogram ids. |
| |
| Subp_Id : Entity_Id; |
| Subp_Index : Entity_Id; |
| -- Subprogram_Id as read from the incoming stream |
| |
| Current_Subp_Number : Int := First_RCI_Subprogram_Id; |
| Current_Stubs : Node_Id; |
| |
| Subp_Info_Array : constant Entity_Id := Make_Temporary (Loc, 'I'); |
| Subp_Info_List : constant List_Id := New_List; |
| |
| Register_Pkg_Actuals : constant List_Id := New_List; |
| |
| All_Calls_Remote_E : Entity_Id; |
| Proxy_Object_Addr : Entity_Id; |
| |
| procedure Append_Stubs_To |
| (RPC_Receiver_Cases : List_Id; |
| Stubs : Node_Id; |
| Subprogram_Number : Int); |
| -- Add one case to the specified RPC receiver case list |
| -- associating Subprogram_Number with the subprogram declared |
| -- by Declaration, for which we have receiving stubs in Stubs. |
| |
| procedure Visit_Subprogram (Decl : Node_Id); |
| -- Generate receiving stub for one remote subprogram |
| |
| --------------------- |
| -- Append_Stubs_To -- |
| --------------------- |
| |
| procedure Append_Stubs_To |
| (RPC_Receiver_Cases : List_Id; |
| Stubs : Node_Id; |
| Subprogram_Number : Int) |
| is |
| begin |
| Append_To (RPC_Receiver_Cases, |
| Make_Case_Statement_Alternative (Loc, |
| Discrete_Choices => |
| New_List (Make_Integer_Literal (Loc, Subprogram_Number)), |
| Statements => |
| New_List ( |
| Make_Procedure_Call_Statement (Loc, |
| Name => |
| New_Occurrence_Of (Defining_Entity (Stubs), Loc), |
| Parameter_Associations => New_List ( |
| New_Occurrence_Of (Request_Parameter, Loc)))))); |
| end Append_Stubs_To; |
| |
| ---------------------- |
| -- Visit_Subprogram -- |
| ---------------------- |
| |
| procedure Visit_Subprogram (Decl : Node_Id) is |
| Loc : constant Source_Ptr := Sloc (Decl); |
| Spec : constant Node_Id := Specification (Decl); |
| Subp_Def : constant Entity_Id := Defining_Unit_Name (Spec); |
| |
| Subp_Val : String_Id; |
| pragma Warnings (Off, Subp_Val); |
| |
| begin |
| -- Disable expansion of stubs if serious errors have been |
| -- diagnosed, because otherwise some illegal remote subprogram |
| -- declarations could cause cascaded errors in stubs. |
| |
| if Serious_Errors_Detected /= 0 then |
| return; |
| end if; |
| |
| -- Build receiving stub |
| |
| Current_Stubs := |
| Build_Subprogram_Receiving_Stubs |
| (Vis_Decl => Decl, |
| Asynchronous => |
| Nkind (Spec) = N_Procedure_Specification |
| and then Is_Asynchronous (Subp_Def)); |
| |
| Append_To (Decls, Current_Stubs); |
| Analyze (Current_Stubs); |
| |
| -- Build RAS proxy |
| |
| Add_RAS_Proxy_And_Analyze (Decls, |
| Vis_Decl => Decl, |
| All_Calls_Remote_E => All_Calls_Remote_E, |
| Proxy_Object_Addr => Proxy_Object_Addr); |
| |
| -- Compute distribution identifier |
| |
| Assign_Subprogram_Identifier |
| (Subp_Def, Current_Subp_Number, Subp_Val); |
| |
| pragma Assert (Current_Subp_Number = Get_Subprogram_Id (Subp_Def)); |
| |
| -- Add subprogram descriptor (RCI_Subp_Info) to the subprograms |
| -- table for this receiver. This aggregate must be kept consistent |
| -- with the declaration of RCI_Subp_Info in |
| -- System.Partition_Interface. |
| |
| Append_To (Subp_Info_List, |
| Make_Component_Association (Loc, |
| Choices => New_List ( |
| Make_Integer_Literal (Loc, Current_Subp_Number)), |
| |
| Expression => |
| Make_Aggregate (Loc, |
| Component_Associations => New_List ( |
| |
| -- Addr => |
| |
| Make_Component_Association (Loc, |
| Choices => |
| New_List (Make_Identifier (Loc, Name_Addr)), |
| Expression => |
| New_Occurrence_Of (Proxy_Object_Addr, Loc)))))); |
| |
| Append_Stubs_To (Pkg_RPC_Receiver_Cases, |
| Stubs => Current_Stubs, |
| Subprogram_Number => Current_Subp_Number); |
| |
| Current_Subp_Number := Current_Subp_Number + 1; |
| end Visit_Subprogram; |
| |
| procedure Visit_Spec is new Build_Package_Stubs (Visit_Subprogram); |
| |
| -- Start of processing for Add_Receiving_Stubs_To_Declarations |
| |
| begin |
| -- Building receiving stubs consist in several operations: |
| |
| -- - a package RPC receiver must be built. This subprogram |
| -- will get a Subprogram_Id from the incoming stream |
| -- and will dispatch the call to the right subprogram; |
| |
| -- - a receiving stub for each subprogram visible in the package |
| -- spec. This stub will read all the parameters from the stream, |
| -- and put the result as well as the exception occurrence in the |
| -- output stream; |
| |
| -- - a dummy package with an empty spec and a body made of an |
| -- elaboration part, whose job is to register the receiving |
| -- part of this RCI package on the name server. This is done |
| -- by calling System.Partition_Interface.Register_Receiving_Stub. |
| |
| Build_RPC_Receiver_Body ( |
| RPC_Receiver => Pkg_RPC_Receiver, |
| Request => Request_Parameter, |
| Subp_Id => Subp_Id, |
| Subp_Index => Subp_Index, |
| Stmts => Pkg_RPC_Receiver_Statements, |
| Decl => Pkg_RPC_Receiver_Body); |
| pragma Assert (Subp_Id = Subp_Index); |
| |
| -- A null subp_id denotes a call through a RAS, in which case the |
| -- next Uint_64 element in the stream is the address of the local |
| -- proxy object, from which we can retrieve the actual subprogram id. |
| |
| Append_To (Pkg_RPC_Receiver_Statements, |
| Make_Implicit_If_Statement (Pkg_Spec, |
| Condition => |
| Make_Op_Eq (Loc, |
| New_Occurrence_Of (Subp_Id, Loc), |
| Make_Integer_Literal (Loc, 0)), |
| |
| Then_Statements => New_List ( |
| Make_Assignment_Statement (Loc, |
| Name => |
| New_Occurrence_Of (Subp_Id, Loc), |
| |
| Expression => |
| Make_Selected_Component (Loc, |
| Prefix => |
| Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access), |
| OK_Convert_To (RTE (RE_Address), |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| New_Occurrence_Of (RTE (RE_Unsigned_64), Loc), |
| Attribute_Name => |
| Name_Input, |
| Expressions => New_List ( |
| Make_Selected_Component (Loc, |
| Prefix => Request_Parameter, |
| Selector_Name => Name_Params))))), |
| |
| Selector_Name => Make_Identifier (Loc, Name_Subp_Id)))))); |
| |
| -- Build a subprogram for RAS information lookups |
| |
| Lookup_RAS := |
| Make_Subprogram_Declaration (Loc, |
| Specification => |
| Make_Function_Specification (Loc, |
| Defining_Unit_Name => |
| Lookup_RAS_Info, |
| Parameter_Specifications => New_List ( |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, Name_Subp_Id), |
| In_Present => |
| True, |
| Parameter_Type => |
| New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc))), |
| Result_Definition => |
| New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))); |
| Append_To (Decls, Lookup_RAS); |
| Analyze (Lookup_RAS); |
| |
| Current_Stubs := Build_Subprogram_Receiving_Stubs |
| (Vis_Decl => Lookup_RAS, |
| Asynchronous => False); |
| Append_To (Decls, Current_Stubs); |
| Analyze (Current_Stubs); |
| |
| Append_Stubs_To (Pkg_RPC_Receiver_Cases, |
| Stubs => Current_Stubs, |
| Subprogram_Number => 1); |
| |
| -- For each subprogram, the receiving stub will be built and a |
| -- case statement will be made on the Subprogram_Id to dispatch |
| -- to the right subprogram. |
| |
| All_Calls_Remote_E := |
| Boolean_Literals |
| (Has_All_Calls_Remote (Defining_Entity (Pkg_Spec))); |
| |
| Overload_Counter_Table.Reset; |
| |
| Visit_Spec (Pkg_Spec); |
| |
| -- If we receive an invalid Subprogram_Id, it is best to do nothing |
| -- rather than raising an exception since we do not want someone |
| -- to crash a remote partition by sending invalid subprogram ids. |
| -- This is consistent with the other parts of the case statement |
| -- since even in presence of incorrect parameters in the stream, |
| -- every exception will be caught and (if the subprogram is not an |
| -- APC) put into the result stream and sent away. |
| |
| Append_To (Pkg_RPC_Receiver_Cases, |
| Make_Case_Statement_Alternative (Loc, |
| Discrete_Choices => New_List (Make_Others_Choice (Loc)), |
| Statements => New_List (Make_Null_Statement (Loc)))); |
| |
| Append_To (Pkg_RPC_Receiver_Statements, |
| Make_Case_Statement (Loc, |
| Expression => New_Occurrence_Of (Subp_Id, Loc), |
| Alternatives => Pkg_RPC_Receiver_Cases)); |
| |
| Append_To (Decls, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Subp_Info_Array, |
| Constant_Present => True, |
| Aliased_Present => True, |
| Object_Definition => |
| Make_Subtype_Indication (Loc, |
| Subtype_Mark => |
| New_Occurrence_Of (RTE (RE_RCI_Subp_Info_Array), Loc), |
| Constraint => |
| Make_Index_Or_Discriminant_Constraint (Loc, |
| New_List ( |
| Make_Range (Loc, |
| Low_Bound => Make_Integer_Literal (Loc, |
| First_RCI_Subprogram_Id), |
| High_Bound => |
| Make_Integer_Literal (Loc, |
| Intval => |
| First_RCI_Subprogram_Id |
| + List_Length (Subp_Info_List) - 1))))))); |
| |
| -- For a degenerate RCI with no visible subprograms, Subp_Info_List |
| -- has zero length, and the declaration is for an empty array, in |
| -- which case no initialization aggregate must be generated. |
| |
| if Present (First (Subp_Info_List)) then |
| Set_Expression (Last (Decls), |
| Make_Aggregate (Loc, |
| Component_Associations => Subp_Info_List)); |
| |
| -- No initialization provided: remove CONSTANT so that the |
| -- declaration is not an incomplete deferred constant. |
| |
| else |
| Set_Constant_Present (Last (Decls), False); |
| end if; |
| |
| Analyze (Last (Decls)); |
| |
| declare |
| Subp_Info_Addr : Node_Id; |
| -- Return statement for Lookup_RAS_Info: address of the subprogram |
| -- information record for the requested subprogram id. |
| |
| begin |
| if Present (First (Subp_Info_List)) then |
| Subp_Info_Addr := |
| Make_Selected_Component (Loc, |
| Prefix => |
| Make_Indexed_Component (Loc, |
| Prefix => New_Occurrence_Of (Subp_Info_Array, Loc), |
| Expressions => New_List ( |
| Convert_To (Standard_Integer, |
| Make_Identifier (Loc, Name_Subp_Id)))), |
| Selector_Name => Make_Identifier (Loc, Name_Addr)); |
| |
| -- Case of no visible subprogram: just raise Constraint_Error, we |
| -- know for sure we got junk from a remote partition. |
| |
| else |
| Subp_Info_Addr := |
| Make_Raise_Constraint_Error (Loc, |
| Reason => CE_Range_Check_Failed); |
| Set_Etype (Subp_Info_Addr, RTE (RE_Unsigned_64)); |
| end if; |
| |
| Append_To (Decls, |
| Make_Subprogram_Body (Loc, |
| Specification => |
| Copy_Specification (Loc, Parent (Lookup_RAS_Info)), |
| Declarations => No_List, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => New_List ( |
| Make_Simple_Return_Statement (Loc, |
| Expression => |
| OK_Convert_To |
| (RTE (RE_Unsigned_64), Subp_Info_Addr)))))); |
| end; |
| |
| Analyze (Last (Decls)); |
| |
| Append_To (Decls, Pkg_RPC_Receiver_Body); |
| Analyze (Last (Decls)); |
| |
| -- Name |
| |
| Append_To (Register_Pkg_Actuals, |
| Make_String_Literal (Loc, |
| Strval => |
| Fully_Qualified_Name_String |
| (Defining_Entity (Pkg_Spec), Append_NUL => False))); |
| |
| -- Receiver |
| |
| Append_To (Register_Pkg_Actuals, |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Occurrence_Of (Pkg_RPC_Receiver, Loc), |
| Attribute_Name => Name_Unrestricted_Access)); |
| |
| -- Version |
| |
| Append_To (Register_Pkg_Actuals, |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc), |
| Attribute_Name => Name_Version)); |
| |
| -- Subp_Info |
| |
| Append_To (Register_Pkg_Actuals, |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Occurrence_Of (Subp_Info_Array, Loc), |
| Attribute_Name => Name_Address)); |
| |
| -- Subp_Info_Len |
| |
| Append_To (Register_Pkg_Actuals, |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Occurrence_Of (Subp_Info_Array, Loc), |
| Attribute_Name => Name_Length)); |
| |
| -- Generate the call |
| |
| Append_To (Stmts, |
| Make_Procedure_Call_Statement (Loc, |
| Name => |
| New_Occurrence_Of (RTE (RE_Register_Receiving_Stub), Loc), |
| Parameter_Associations => Register_Pkg_Actuals)); |
| Analyze (Last (Stmts)); |
| end Add_Receiving_Stubs_To_Declarations; |
| |
| --------------------------------- |
| -- Build_General_Calling_Stubs -- |
| --------------------------------- |
| |
| procedure Build_General_Calling_Stubs |
| (Decls : List_Id; |
| Statements : List_Id; |
| Target_Partition : Entity_Id; |
| Target_RPC_Receiver : Node_Id; |
| Subprogram_Id : Node_Id; |
| Asynchronous : Node_Id := Empty; |
| Is_Known_Asynchronous : Boolean := False; |
| Is_Known_Non_Asynchronous : Boolean := False; |
| Is_Function : Boolean; |
| Spec : Node_Id; |
| Stub_Type : Entity_Id := Empty; |
| RACW_Type : Entity_Id := Empty; |
| Nod : Node_Id) |
| is |
| Loc : constant Source_Ptr := Sloc (Nod); |
| |
| Stream_Parameter : Node_Id; |
| -- Name of the stream used to transmit parameters to the remote |
| -- package. |
| |
| Result_Parameter : Node_Id; |
| -- Name of the result parameter (in non-APC cases) which get the |
| -- result of the remote subprogram. |
| |
| Exception_Return_Parameter : Node_Id; |
| -- Name of the parameter which will hold the exception sent by the |
| -- remote subprogram. |
| |
| Current_Parameter : Node_Id; |
| -- Current parameter being handled |
| |
| Ordered_Parameters_List : constant List_Id := |
| Build_Ordered_Parameters_List (Spec); |
| |
| Asynchronous_Statements : List_Id := No_List; |
| Non_Asynchronous_Statements : List_Id := No_List; |
| -- Statements specifics to the Asynchronous/Non-Asynchronous cases |
| |
| Extra_Formal_Statements : constant List_Id := New_List; |
| -- List of statements for extra formal parameters. It will appear |
| -- after the regular statements for writing out parameters. |
| |
| pragma Unreferenced (RACW_Type); |
| -- Used only for the PolyORB case |
| |
| begin |
| -- The general form of a calling stub for a given subprogram is: |
| |
| -- procedure X (...) is P : constant Partition_ID := |
| -- RCI_Cache.Get_Active_Partition_ID; Stream, Result : aliased |
| -- System.RPC.Params_Stream_Type (0); begin |
| -- Put_Package_RPC_Receiver_In_Stream; (the package RPC receiver |
| -- comes from RCI_Cache.Get_RCI_Package_Receiver) |
| -- Put_Subprogram_Id_In_Stream; Put_Parameters_In_Stream; Do_RPC |
| -- (Stream, Result); Read_Exception_Occurrence_From_Result; |
| -- Raise_It; |
| -- Read_Out_Parameters_And_Function_Return_From_Stream; end X; |
| |
| -- There are some variations: Do_APC is called for an asynchronous |
| -- procedure and the part after the call is completely ommitted as |
| -- well as the declaration of Result. For a function call, 'Input is |
| -- always used to read the result even if it is constrained. |
| |
|