| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT COMPILER COMPONENTS -- |
| -- -- |
| -- E X P_ D I S T -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 1992-2021, 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 Einfo.Entities; use Einfo.Entities; |
| with Einfo.Utils; use Einfo.Utils; |
| with Elists; use Elists; |
| with Exp_Atag; use Exp_Atag; |
| with Exp_Strm; use Exp_Strm; |
| with Exp_Tss; use Exp_Tss; |
| with Exp_Util; use Exp_Util; |
| with Lib; use Lib; |
| with Nlists; use Nlists; |
| with Nmake; use Nmake; |
| with Opt; use Opt; |
| with Rtsfind; use Rtsfind; |
| with Sem; use Sem; |
| with Sem_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 Sinfo.Nodes; use Sinfo.Nodes; |
| with Sinfo.Utils; use Sinfo.Utils; |
| 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; |
| 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. |
| |
| -------------------- |
| -- 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 := Empty; |
| -- 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_Pkg -- |
| ---------------------- |
| |
| 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, including the wrapper package for an instance |
| -- of a generic subprogram. |
| |
| 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_Unit_Instantiation_Node (Pkg_Ent))) |
| then |
| Visit_Nested_Pkg (Decl); |
| end if; |
| end; |
| |
| 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; |
| 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 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 := No_List; |
| RPC_Receiver_Request : Entity_Id := Empty; |
| RPC_Receiver_Subp_Id : Entity_Id := Empty; |
| RPC_Receiver_Subp_Index : Entity_Id := Empty; |
| |
| 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_Put_Image) 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)); |
| |
| Mutate_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); |
| |
| Mutate_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'); |
| Mutate_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))); |
| Mutate_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 |
| Mutate_Ekind (Object, E_Constant); |
| else |
| Mutate_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_Access_Function_Definition |
| | N_Function_Specification |
| => |
| 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_Access_Procedure_Definition |
| | N_Procedure_Specification |
| => |
| 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 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. |
| |
| Mutate_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. |
| |
| Stream_Parameter := Make_Temporary (Loc, 'S'); |
| |
| Append_To (Decls, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Stream_Parameter, |
| Aliased_Present => True, |
| Object_Definition => |
| Make_Subtype_Indication (Loc, |
| Subtype_Mark => |
| New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc), |
| Constraint => |
| Make_Index_Or_Discriminant_Constraint (Loc, |
| Constraints => |
| New_List (Make_Integer_Literal (Loc, 0)))))); |
| |
| if not Is_Known_Asynchronous then |
| Result_Parameter := Make_Temporary (Loc, 'R'); |
| |
| Append_To (Decls, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Result_Parameter, |
| Aliased_Present => True, |
| Object_Definition => |
| Make_Subtype_Indication (Loc, |
| Subtype_Mark => |
| New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc), |
| Constraint => |
| Make_Index_Or_Discriminant_Constraint (Loc, |
| Constraints => |
| New_List (Make_Integer_Literal (Loc, 0)))))); |
| |
| Exception_Return_Parameter := Make_Temporary (Loc, 'E'); |
| |
| Append_To (Decls, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Exception_Return_Parameter, |
| Object_Definition => |
| New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc))); |
| |
| else |
| Result_Parameter := Empty; |
| Exception_Return_Parameter := Empty; |
| end if; |
| |
| -- Put first the RPC receiver corresponding to the remote package |
| |
| Append_To (Statements, |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| New_Occurrence_Of (RTE (RE_Unsigned_64), Loc), |
| Attribute_Name => Name_Write, |
| Expressions => New_List ( |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Occurrence_Of (Stream_Parameter, Loc), |
| Attribute_Name => Name_Access), |
| Target_RPC_Receiver))); |
| |
| -- Then put the Subprogram_Id of the subprogram we want to call in |
| -- the stream. |
| |
| Append_To (Statements, |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc), |
| Attribute_Name => Name_Write, |
| Expressions => New_List ( |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Occurrence_Of (Stream_Parameter, Loc), |
| Attribute_Name => Name_Access), |
| Subprogram_Id))); |
| |
| Current_Parameter := First (Ordered_Parameters_List); |
| while Present (Current_Parameter) loop |
| declare |
| Typ : constant Node_Id := |
| Parameter_Type (Current_Parameter); |
| Etyp : Entity_Id; |
| Constrained : Boolean; |
| Value : Node_Id; |
| Extra_Parameter : Entity_Id; |
| |
| begin |
| if Is_RACW_Controlling_Formal |
| (Current_Parameter, Stub_Type) |
| then |
| -- In the case of a controlling formal argument, we marshall |
| -- its addr field rather than the local stub. |
| |
| Append_To (Statements, |
| Pack_Node_Into_Stream (Loc, |
| Stream => Stream_Parameter, |
| Object => |
| Make_Selected_Component (Loc, |
| Prefix => |
| Defining_Identifier (Current_Parameter), |
| Selector_Name => Name_Addr), |
| Etyp => RTE (RE_Unsigned_64))); |
| |
| else |
| Value := |
| New_Occurrence_Of |
| (Defining_Identifier (Current_Parameter), Loc); |
| |
| -- Access type parameters are transmitted as in out |
| -- parameters. However, a dereference is needed so that |
| -- we marshall the designated object. |
| |
| if Nkind (Typ) = N_Access_Definition then |
| Value := Make_Explicit_Dereference (Loc, Value); |
| Etyp := Etype (Subtype_Mark (Typ)); |
| else |
| Etyp := Etype (Typ); |
| end if; |
| |
| Constrained := not Transmit_As_Unconstrained (Etyp); |
| |
| -- Any parameter but unconstrained out parameters are |
| -- transmitted to the peer. |
| |
| if In_Present (Current_Parameter) |
| or else not Out_Present (Current_Parameter) |
| or else not Constrained |
| then |
| Append_To (Statements, |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Occurrence_Of (Etyp, Loc), |
| Attribute_Name => |
| Output_From_Constrained (Constrained), |
| Expressions => New_List ( |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| New_Occurrence_Of (Stream_Parameter, Loc), |
| Attribute_Name => Name_Access), |
| Value))); |
| end if; |
| end if; |
| |
| -- If the current parameter has a dynamic constrained status, |
| -- then this status is transmitted as well. |
| -- This should be done for accessibility as well ??? |
| |
| if Nkind (Typ) /= N_Access_Definition |
| and then Need_Extra_Constrained (Current_Parameter) |
| then |
| -- In this block, we do not use the extra formal that has |
| -- been created because it does not exist at the time of |
| -- expansion when building calling stubs for remote access |
| -- to subprogram types. We create an extra variable of this |
| -- type and push it in the stream after the regular |
| -- parameters. |
| |
| Extra_Parameter := Make_Temporary (Loc, 'P'); |
| |
| Append_To (Decls, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Extra_Parameter, |
| Constant_Present => True, |
| Object_Definition => |
| New_Occurrence_Of (Standard_Boolean, Loc), |
| Expression => |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| New_Occurrence_Of ( |
| Defining_Identifier (Current_Parameter), Loc), |
| Attribute_Name => Name_Constrained))); |
| |
| Append_To (Extra_Formal_Statements, |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| New_Occurrence_Of (Standard_Boolean, Loc), |
| Attribute_Name => Name_Write, |
| Expressions => New_List ( |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| New_Occurrence_Of |
| (Stream_Parameter, Loc), Attribute_Name => |
| Name_Access), |
| New_Occurrence_Of (Extra_Parameter, Loc)))); |
| end if; |
| |
| Next (Current_Parameter); |
| end; |
| end loop; |
| |
| -- Append the formal statements list to the statements |
| |
| Append_List_To (Statements, Extra_Formal_Statements); |
| |
| if not Is_Known_Non_Asynchronous then |
| |
| -- Build the call to System.RPC.Do_APC |
| |
| Asynchronous_Statements := New_List ( |
| Make_Procedure_Call_Statement (Loc, |
| Name => |
| New_Occurrence_Of (RTE (RE_Do_Apc), Loc), |
| Parameter_Associations => New_List ( |
| New_Occurrence_Of (Target_Partition, Loc), |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| New_Occurrence_Of (Stream_Parameter, Loc), |
| Attribute_Name => Name_Access)))); |
| else |
| Asynchronous_Statements := No_List; |
| end if; |
| |
| if not Is_Known_Asynchronous then |
| |
| -- Build the call to System.RPC.Do_RPC |
| |
| Non_Asynchronous_Statements := New_List ( |
| Make_Procedure_Call_Statement (Loc, |
| Name => |
| New_Occurrence_Of (RTE (RE_Do_Rpc), Loc), |
| Parameter_Associations => New_List ( |
| New_Occurrence_Of (Target_Partition, Loc), |
| |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| New_Occurrence_Of (Stream_Parameter, Loc), |
| Attribute_Name => Name_Access), |
| |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| New_Occurrence_Of (Result_Parameter, Loc), |
| Attribute_Name => Name_Access)))); |
| |
| -- Read the exception occurrence from the result stream and |
| -- reraise it. It does no harm if this is a Null_Occurrence since |
| -- this does nothing. |
| |
| Append_To (Non_Asynchronous_Statements, |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc), |
| |
| Attribute_Name => Name_Read, |
| |
| Expressions => New_List ( |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| New_Occurrence_Of (Result_Parameter, Loc), |
| Attribute_Name => Name_Access), |
| New_Occurrence_Of (Exception_Return_Parameter, Loc)))); |
| |
| Append_To (Non_Asynchronous_Statements, |
| Make_Procedure_Call_Statement (Loc, |
| Name => |
| New_Occurrence_Of (RTE (RE_Reraise_Occurrence), Loc), |
| Parameter_Associations => New_List ( |
| New_Occurrence_Of (Exception_Return_Parameter, Loc)))); |
| |
| if Is_Function then |
| |
| -- If this is a function call, then read the value and return |
| -- it. The return value is written/read using 'Output/'Input. |
| |
| Append_To (Non_Asynchronous_Statements, |
| Make_Tag_Check (Loc, |
| Make_Simple_Return_Statement (Loc, |
| Expression => |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| New_Occurrence_Of ( |
| Etype (Result_Definition (Spec)), Loc), |
| |
| Attribute_Name => Name_Input, |
| |
| Expressions => New_List ( |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| New_Occurrence_Of (Result_Parameter, Loc), |
| Attribute_Name => Name_Access)))))); |
| |
| else |
| -- Loop around parameters and assign out (or in out) |
| -- parameters. In the case of RACW, controlling arguments |
| -- cannot possibly have changed since they are remote, so |
| -- we do not read them from the stream. |
| |
| Current_Parameter := First (Ordered_Parameters_List); |
| while Present (Current_Parameter) loop |
| declare |
| Typ : constant Node_Id := |
| Parameter_Type (Current_Parameter); |
| Etyp : Entity_Id; |
| Value : Node_Id; |
| |
| begin |
| Value := |
| New_Occurrence_Of |
| (Defining_Identifier (Current_Parameter), Loc); |
| |
| if Nkind (Typ) = N_Access_Definition then |
| Value := Make_Explicit_Dereference (Loc, Value); |
| Etyp := Etype (Subtype_Mark (Typ)); |
| else |
| Etyp := Etype (Typ); |
| end if; |
| |
| if (Out_Present (Current_Parameter) |
| or else Nkind (Typ) = N_Access_Definition) |
| and then Etyp /= Stub_Type |
| then |
| Append_To (Non_Asynchronous_Statements, |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| New_Occurrence_Of (Etyp, Loc), |
| |
| Attribute_Name => Name_Read, |
| |
| Expressions => New_List ( |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| New_Occurrence_Of (Result_Parameter, Loc), |
| Attribute_Name => Name_Access), |
| Value))); |
| end if; |
| end; |
| |
| Next (Current_Parameter); |
| end loop; |
| end if; |
| end if; |
| |
| if Is_Known_Asynchronous then |
| Append_List_To (Statements, Asynchronous_Statements); |
| |
| elsif Is_Known_Non_Asynchronous then |
| Append_List_To (Statements, Non_Asynchronous_Statements); |
| |
| else |
| pragma Assert (Present (Asynchronous)); |
| Prepend_To (Asynchronous_Statements, |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Occurrence_Of (Standard_Boolean, Loc), |
| Attribute_Name => Name_Write, |
| Expressions => New_List ( |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| New_Occurrence_Of (Stream_Parameter, Loc), |
| Attribute_Name => Name_Access), |
| New_Occurrence_Of (Standard_True, Loc)))); |
| |
| Prepend_To (Non_Asynchronous_Statements, |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Occurrence_Of (Standard_Boolean, Loc), |
| Attribute_Name => Name_Write, |
| Expressions => New_List ( |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| New_Occurrence_Of (Stream_Parameter, Loc), |
| Attribute_Name => Name_Access), |
| New_Occurrence_Of (Standard_False, Loc)))); |
| |
| Append_To (Statements, |
| Make_Implicit_If_Statement (Nod, |
| Condition => Asynchronous, |
| Then_Statements => Asynchronous_Statements, |
| Else_Statements => Non_Asynchronous_Statements)); |
| end if; |
| end Build_General_Calling_Stubs; |
| |
| ----------------------------- |
| -- Build_RPC_Receiver_Body -- |
| ----------------------------- |
| |
| procedure Build_RPC_Receiver_Body |
| (RPC_Receiver : Entity_Id; |
| Request : out Entity_Id; |
| Subp_Id : out Entity_Id; |
| Subp_Index : out Entity_Id; |
| Stmts : out List_Id; |
| Decl : out Node_Id) |
| is |
| Loc : constant Source_Ptr := Sloc (RPC_Receiver); |
| |
| RPC_Receiver_Spec : Node_Id; |
| RPC_Receiver_Decls : List_Id; |
| |
| begin |
| Request := Make_Defining_Identifier (Loc, Name_R); |
| |
| RPC_Receiver_Spec := |
| Build_RPC_Receiver_Specification |
| (RPC_Receiver => RPC_Receiver, |
| Request_Parameter => Request); |
| |
| Subp_Id := Make_Temporary (Loc, 'P'); |
| Subp_Index := Subp_Id; |
| |
| -- Subp_Id may not be a constant, because in the case of the RPC |
| -- receiver for an RCI package, when a call is received from a RAS |
| -- dereference, it will be assigned during subsequent processing. |
| |
| RPC_Receiver_Decls := New_List ( |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Subp_Id, |
| Object_Definition => |
| New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc), |
| Expression => |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc), |
| Attribute_Name => Name_Input, |
| Expressions => New_List ( |
| Make_Selected_Component (Loc, |
| Prefix => Request, |
| Selector_Name => Name_Params))))); |
| |
| Stmts := New_List; |
| |
| Decl := |
| Make_Subprogram_Body (Loc, |
| Specification => RPC_Receiver_Spec, |
| Declarations => RPC_Receiver_Decls, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => Stmts)); |
| end Build_RPC_Receiver_Body; |
| |
| ----------------------- |
| -- Build_Stub_Target -- |
| ----------------------- |
| |
| function Build_Stub_Target |
| (Loc : Source_Ptr; |
| Decls : List_Id; |
| RCI_Locator : Entity_Id; |
| Controlling_Parameter : Entity_Id) return RPC_Target |
| is |
| Target_Info : RPC_Target (PCS_Kind => Name_GARLIC_DSA); |
| |
| begin |
| Target_Info.Partition := Make_Temporary (Loc, 'P'); |
| |
| if Present (Controlling_Parameter) then |
| Append_To (Decls, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Target_Info.Partition, |
| Constant_Present => True, |
| Object_Definition => |
| New_Occurrence_Of (RTE (RE_Partition_ID), Loc), |
| |
| Expression => |
| Make_Selected_Component (Loc, |
| Prefix => Controlling_Parameter, |
| Selector_Name => Name_Origin))); |
| |
| Target_Info.RPC_Receiver := |
| Make_Selected_Component (Loc, |
| Prefix => Controlling_Parameter, |
| Selector_Name => Name_Receiver); |
| |
| else |
| Append_To (Decls, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Target_Info.Partition, |
| Constant_Present => True, |
| Object_Definition => |
| New_Occurrence_Of (RTE (RE_Partition_ID), Loc), |
| |
| Expression => |
| Make_Function_Call (Loc, |
| Name => Make_Selected_Component (Loc, |
| Prefix => |
| Make_Identifier (Loc, Chars (RCI_Locator)), |
| Selector_Name => |
| Make_Identifier (Loc, |
| Name_Get_Active_Partition_ID))))); |
| |
| Target_Info.RPC_Receiver := |
| Make_Selected_Component (Loc, |
| Prefix => |
| Make_Identifier (Loc, Chars (RCI_Locator)), |
| Selector_Name => |
| Make_Identifier (Loc, Name_Get_RCI_Package_Receiver)); |
| end if; |
| return Target_Info; |
| end Build_Stub_Target; |
| |
| -------------------------------------- |
| -- Build_Subprogram_Receiving_Stubs -- |
| -------------------------------------- |
| |
| function Build_Subprogram_Receiving_Stubs |
| (Vis_Decl : Node_Id; |
| Asynchronous : Boolean; |
| Dynamically_Asynchronous : Boolean := False; |
| Stub_Type : Entity_Id := Empty; |
| RACW_Type : Entity_Id := Empty; |
| Parent_Primitive : Entity_Id := Empty) return Node_Id |
| is |
| Loc : constant Source_Ptr := Sloc (Vis_Decl); |
| |
| Request_Parameter : constant Entity_Id := Make_Temporary (Loc, 'R'); |
| -- Formal parameter for receiving stubs: a descriptor for an incoming |
| -- request. |
| |
| Decls : constant List_Id := New_List; |
| -- All the parameters will get declared before calling the real |
| -- subprograms. Also the out parameters will be declared. |
| |
| Statements : constant List_Id := New_List; |
| |
| Extra_Formal_Statements : constant List_Id := New_List; |
| -- Statements concerning extra formal parameters |
| |
| After_Statements : constant List_Id := New_List; |
| -- Statements to be executed after the subprogram call |
| |
| Inner_Decls : List_Id := No_List; |
| -- In case of a function, the inner declarations are needed since |
| -- the result may be unconstrained. |
| |
| Excep_Handlers : List_Id := No_List; |
| Excep_Choice : Entity_Id; |
| Excep_Code : List_Id; |
| |
| Parameter_List : constant List_Id := New_List; |
| -- List of parameters to be passed to the subprogram |
| |
| Current_Parameter : Node_Id; |
| |
| Ordered_Parameters_List : constant List_Id := |
| Build_Ordered_Parameters_List |
| (Specification (Vis_Decl)); |
| |
| Subp_Spec : Node_Id; |
| -- Subprogram specification |
| |
| Called_Subprogram : Node_Id; |
| -- The subprogram to call |
| |
| Null_Raise_Statement : Node_Id; |
| |
| Dynamic_Async : Entity_Id; |
| |
| begin |
| if Present (RACW_Type) then |
| Called_Subprogram := New_Occurrence_Of (Parent_Primitive, Loc); |
| else |
| Called_Subprogram := |
| New_Occurrence_Of |
| (Defining_Unit_Name (Specification (Vis_Decl)), Loc); |
| end if; |
| |
| if Dynamically_Asynchronous then |
| Dynamic_Async := Make_Temporary (Loc, 'S'); |
| else |
| Dynamic_Async := Empty; |
| end if; |
| |
| if not Asynchronous or Dynamically_Asynchronous then |
| |
| -- The first statement after the subprogram call is a statement to |
| -- write a Null_Occurrence into the result stream. |
| |
| Null_Raise_Statement := |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc), |
| Attribute_Name => Name_Write, |
| Expressions => New_List ( |
| Make_Selected_Component (Loc, |
| Prefix => Request_Parameter, |
| Selector_Name => Name_Result), |
| New_Occurrence_Of (RTE (RE_Null_Occurrence), Loc))); |
| |
| if Dynamically_Asynchronous then |
| Null_Raise_Statement := |
| Make_Implicit_If_Statement (Vis_Decl, |
| Condition => |
| Make_Op_Not (Loc, New_Occurrence_Of (Dynamic_Async, Loc)), |
| Then_Statements => New_List (Null_Raise_Statement)); |
| end if; |
| |
| Append_To (After_Statements, Null_Raise_Statement); |
| end if; |
| |
| -- Loop through every parameter and get its value from the stream. If |
| -- the parameter is unconstrained, then the parameter is read using |
| -- 'Input at the point of declaration. |
| |
| Current_Parameter := First (Ordered_Parameters_List); |
| while Present (Current_Parameter) loop |
| declare |
| Etyp : Entity_Id; |
| Constrained : Boolean; |
| |
| Need_Extra_Constrained : Boolean; |
| -- True when an Extra_Constrained actual is required |
| |
| Object : constant Entity_Id := Make_Temporary (Loc, 'P'); |
| |
| Expr : Node_Id := Empty; |
| |
| Is_Controlling_Formal : constant Boolean := |
| Is_RACW_Controlling_Formal |
| (Current_Parameter, Stub_Type); |
| |
| begin |
| if Is_Controlling_Formal then |
| |
| -- We have a controlling formal parameter. Read its address |
| -- rather than a real object. The address is in Unsigned_64 |
| -- form. |
| |
| Etyp := RTE (RE_Unsigned_64); |
| else |
| Etyp := Etype (Parameter_Type (Current_Parameter)); |
| end if; |
| |
| Constrained := not Transmit_As_Unconstrained (Etyp); |
| |
| if In_Present (Current_Parameter) |
| or else not Out_Present (Current_Parameter) |
| or else not Constrained |
| or else Is_Controlling_Formal |
| then |
| -- If an input parameter is constrained, then the read of |
| -- the parameter is deferred until the beginning of the |
| -- subprogram body. If it is unconstrained, then an |
| -- expression is built for the object declaration and the |
| -- variable is set using 'Input instead of 'Read. Note that |
| -- this deferral does not change the order in which the |
| -- actuals are read because Build_Ordered_Parameter_List |
| -- puts them unconstrained first. |
| |
| if Constrained then |
| Append_To (Statements, |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Occurrence_Of (Etyp, Loc), |
| Attribute_Name => Name_Read, |
| Expressions => New_List ( |
| Make_Selected_Component (Loc, |
| Prefix => Request_Parameter, |
| Selector_Name => Name_Params), |
| New_Occurrence_Of (Object, Loc)))); |
| |
| else |
| |
| -- Build and append Input_With_Tag_Check function |
| |
| Append_To (Decls, |
| Input_With_Tag_Check (Loc, |
| Var_Type => Etyp, |
| Stream => |
| Make_Selected_Component (Loc, |
| Prefix => Request_Parameter, |
| Selector_Name => Name_Params))); |
| |
| -- Prepare function call expression |
| |
| Expr := |
| Make_Function_Call (Loc, |
| Name => |
| New_Occurrence_Of |
| (Defining_Unit_Name |
| (Specification (Last (Decls))), Loc)); |
| end if; |
| end if; |
| |
| Need_Extra_Constrained := |
| Nkind (Parameter_Type (Current_Parameter)) /= |
| N_Access_Definition |
| and then |
| Ekind (Defining_Identifier (Current_Parameter)) /= E_Void |
| and then |
| Present (Extra_Constrained |
| (Defining_Identifier (Current_Parameter))); |
| |
| -- We may not associate an extra constrained actual to a |
| -- constant object, so if one is needed, declare the actual |
| -- as a variable even if it won't be modified. |
| |
| Build_Actual_Object_Declaration |
| (Object => Object, |
| Etyp => Etyp, |
| Variable => Need_Extra_Constrained |
| or else Out_Present (Current_Parameter), |
| Expr => Expr, |
| Decls => Decls); |
| |
| -- An out parameter may be written back using a 'Write |
| -- attribute instead of a 'Output because it has been |
| -- constrained by the parameter given to the caller. Note that |
| -- out controlling arguments in the case of a RACW are not put |
| -- back in the stream because the pointer on them has not |
| -- changed. |
| |
| if Out_Present (Current_Parameter) |
| and then |
| Etype (Parameter_Type (Current_Parameter)) /= Stub_Type |
| then |
| Append_To (After_Statements, |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Occurrence_Of (Etyp, Loc), |
| Attribute_Name => Name_Write, |
| Expressions => New_List ( |
| Make_Selected_Component (Loc, |
| Prefix => Request_Parameter, |
| Selector_Name => Name_Result), |
| New_Occurrence_Of (Object, Loc)))); |
| end if; |
| |
| -- For RACW controlling formals, the Etyp of Object is always |
| -- an RACW, even if the parameter is not of an anonymous access |
| -- type. In such case, we need to dereference it at call time. |
| |
| if Is_Controlling_Formal then |
| if Nkind (Parameter_Type (Current_Parameter)) /= |
| N_Access_Definition |
| then |
| Append_To (Parameter_List, |
| Make_Parameter_Association (Loc, |
| Selector_Name => |
| New_Occurrence_Of ( |
| Defining_Identifier (Current_Parameter), Loc), |
| Explicit_Actual_Parameter => |
| Make_Explicit_Dereference (Loc, |
| Unchecked_Convert_To (RACW_Type, |
| OK_Convert_To (RTE (RE_Address), |
| New_Occurrence_Of (Object, Loc)))))); |
| |
| else |
| Append_To (Parameter_List, |
| Make_Parameter_Association (Loc, |
| Selector_Name => |
| New_Occurrence_Of ( |
| Defining_Identifier (Current_Parameter), Loc), |
| Explicit_Actual_Parameter => |
| Unchecked_Convert_To (RACW_Type, |
| OK_Convert_To (RTE (RE_Address), |
| New_Occurrence_Of (Object, Loc))))); |
| end if; |
| |
| else |
| Append_To (Parameter_List, |
| Make_Parameter_Association (Loc, |
| Selector_Name => |
| New_Occurrence_Of ( |
| Defining_Identifier (Current_Parameter), Loc), |
| Explicit_Actual_Parameter => |
| New_Occurrence_Of (Object, Loc))); |
| end if; |
| |
| -- If the current parameter needs an extra formal, then read it |
| -- from the stream and set the corresponding semantic field in |
| -- the variable. If the kind of the parameter identifier is |
| -- E_Void, then this is a compiler generated parameter that |
| -- doesn't need an extra constrained status. |
| |
| -- The case of Extra_Accessibility should also be handled ??? |
| |
| if Need_Extra_Constrained then |
| declare |
| Extra_Parameter : constant Entity_Id := |
| Extra_Constrained |
| (Defining_Identifier |
| (Current_Parameter)); |
| |
| Formal_Entity : constant Entity_Id := |
| Make_Defining_Identifier |
| (Loc, Chars (Extra_Parameter)); |
| |
| Formal_Type : constant Entity_Id := |
| Etype (Extra_Parameter); |
| |
| begin |
| Append_To (Decls, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Formal_Entity, |
| Object_Definition => |
| New_Occurrence_Of (Formal_Type, Loc))); |
| |
| Append_To (Extra_Formal_Statements, |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Occurrence_Of ( |
| Formal_Type, Loc), |
| Attribute_Name => Name_Read, |
| Expressions => New_List ( |
| Make_Selected_Component (Loc, |
| Prefix => Request_Parameter, |
| Selector_Name => Name_Params), |
| New_Occurrence_Of (Formal_Entity, Loc)))); |
| |
| -- Note: the call to Set_Extra_Constrained below relies |
| -- on the fact that Object's Ekind has been set by |
| -- Build_Actual_Object_Declaration. |
| |
| Set_Extra_Constrained (Object, Formal_Entity); |
| end; |
| end if; |
| end; |
| |
| Next (Current_Parameter); |
| end loop; |
| |
| -- Append the formal statements list at the end of regular statements |
| |
| Append_List_To (Statements, Extra_Formal_Statements); |
| |
| if Nkind (Specification (Vis_Decl)) = N_Function_Specification then |
| |
| -- The remote subprogram is a function. We build an inner block to |
| -- be able to hold a potentially unconstrained result in a |
| -- variable. |
| |
| declare |
| Etyp : constant Entity_Id := |
| Etype (Result_Definition (Specification (Vis_Decl))); |
| Result : constant Node_Id := Make_Temporary (Loc, 'R'); |
| |
| begin |
| Inner_Decls := New_List ( |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Result, |
| Constant_Present => True, |
| Object_Definition => New_Occurrence_Of (Etyp, Loc), |
| Expression => |
| Make_Function_Call (Loc, |
| Name => Called_Subprogram, |
| Parameter_Associations => Parameter_List))); |
| |
| if Is_Class_Wide_Type (Etyp) then |
| |
| -- For a remote call to a function with a class-wide type, |
| -- check that the returned value satisfies the requirements |
| -- of E.4(18). |
| |
| Append_To (Inner_Decls, |
| Make_Transportable_Check (Loc, |
| New_Occurrence_Of (Result, Loc))); |
| |
| end if; |
| |
| Append_To (After_Statements, |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Occurrence_Of (Etyp, Loc), |
| Attribute_Name => Name_Output, |
| Expressions => New_List ( |
| Make_Selected_Component (Loc, |
| Prefix => Request_Parameter, |
| Selector_Name => Name_Result), |
| New_Occurrence_Of (Result, Loc)))); |
| end; |
| |
| Append_To (Statements, |
| Make_Block_Statement (Loc, |
| Declarations => Inner_Decls, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => After_Statements))); |
| |
| else |
| -- The remote subprogram is a procedure. We do not need any inner |
| -- block in this case. |
| |
| if Dynamically_Asynchronous then |
| Append_To (Decls, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Dynamic_Async, |
| Object_Definition => |
| New_Occurrence_Of (Standard_Boolean, Loc))); |
| |
| Append_To (Statements, |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Occurrence_Of (Standard_Boolean, Loc), |
| Attribute_Name => Name_Read, |
| Expressions => New_List ( |
| Make_Selected_Component (Loc, |
| Prefix => Request_Parameter, |
| Selector_Name => Name_Params), |
| New_Occurrence_Of (Dynamic_Async, Loc)))); |
| end if; |
| |
| Append_To (Statements, |
| Make_Procedure_Call_Statement (Loc, |
| Name => Called_Subprogram, |
| Parameter_Associations => Parameter_List)); |
| |
| Append_List_To (Statements, After_Statements); |
| end if; |
| |
| if Asynchronous and then not Dynamically_Asynchronous then |
| |
| -- For an asynchronous procedure, add a null exception handler |
| |
| Excep_Handlers := New_List ( |
| Make_Implicit_Exception_Handler (Loc, |
| Exception_Choices => New_List (Make_Others_Choice (Loc)), |
| Statements => New_List (Make_Null_Statement (Loc)))); |
| |
| else |
| -- In the other cases, if an exception is raised, then the |
| -- exception occurrence is copied into the output stream and |
| -- no other output parameter is written. |
| |
| Excep_Choice := Make_Temporary (Loc, 'E'); |
| |
| Excep_Code := New_List ( |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc), |
| Attribute_Name => Name_Write, |
| Expressions => New_List ( |
| Make_Selected_Component (Loc, |
| Prefix => Request_Parameter, |
| Selector_Name => Name_Result), |
| New_Occurrence_Of (Excep_Choice, Loc)))); |
| |
| if Dynamically_Asynchronous then |
| Excep_Code := New_List ( |
| Make_Implicit_If_Statement (Vis_Decl, |
| Condition => Make_Op_Not (Loc, |
| New_Occurrence_Of (Dynamic_Async, Loc)), |
| Then_Statements => Excep_Code)); |
| end if; |
| |
| Excep_Handlers := New_List ( |
| Make_Implicit_Exception_Handler (Loc, |
| Choice_Parameter => Excep_Choice, |
| Exception_Choices => New_List (Make_Others_Choice (Loc)), |
| Statements => Excep_Code)); |
| |
| end if; |
| |
| Subp_Spec := |
| Make_Procedure_Specification (Loc, |
| Defining_Unit_Name => Make_Temporary (Loc, 'F'), |
| |
| Parameter_Specifications => New_List ( |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => Request_Parameter, |
| Parameter_Type => |
| New_Occurrence_Of (RTE (RE_Request_Access), Loc)))); |
| |
| return |
| Make_Subprogram_Body (Loc, |
| Specification => Subp_Spec, |
| Declarations => Decls, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => Statements, |
| Exception_Handlers => Excep_Handlers)); |
| end Build_Subprogram_Receiving_Stubs; |
| |
| ------------ |
| -- Result -- |
| ------------ |
| |
| function Result return Node_Id is |
| begin |
| return Make_Identifier (Loc, Name_V); |
| end Result; |
| |
| ----------------------- |
| -- RPC_Receiver_Decl -- |
| ----------------------- |
| |
| function RPC_Receiver_Decl (RACW_Type : Entity_Id) return Node_Id is |
| Loc : constant Source_Ptr := Sloc (RACW_Type); |
| Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type); |
| |
| begin |
| -- No RPC receiver for remote access-to-subprogram |
| |
| if Is_RAS then |
| return Empty; |
| end if; |
| |
| return |
| Make_Subprogram_Declaration (Loc, |
| Build_RPC_Receiver_Specification |
| (RPC_Receiver => Make_Temporary (Loc, 'R'), |
| Request_Parameter => Make_Defining_Identifier (Loc, Name_R))); |
| end RPC_Receiver_Decl; |
| |
| ---------------------- |
| -- Stream_Parameter -- |
| ---------------------- |
| |
| function Stream_Parameter return Node_Id is |
| begin |
| return Make_Identifier (Loc, Name_S); |
| end Stream_Parameter; |
| |
| end GARLIC_Support; |
| |
| ------------------------------- |
| -- Get_And_Reset_RACW_Bodies -- |
| ------------------------------- |
| |
| function Get_And_Reset_RACW_Bodies (RACW_Type : Entity_Id) return List_Id is |
| Desig : constant Entity_Id := |
| Etype (Designated_Type (RACW_Type)); |
| |
| Stub_Elements : Stub_Structure := Stubs_Table.Get (Desig); |
| |
| Body_Decls : List_Id; |
| -- Returned list of declarations |
| |
| begin |
| if Stub_Elements = Empty_Stub_Structure then |
| |
| -- Stub elements may be missing as a consequence of a previously |
| -- detected error. |
| |
| return No_List; |
| end if; |
| |
| Body_Decls := Stub_Elements.Body_Decls; |
| Stub_Elements.Body_Decls := No_List; |
| Stubs_Table.Set (Desig, Stub_Elements); |
| return Body_Decls; |
| end Get_And_Reset_RACW_Bodies; |
| |
| ----------------------- |
| -- Get_Stub_Elements -- |
| ----------------------- |
| |
| function Get_Stub_Elements (RACW_Type : Entity_Id) return Stub_Structure is |
| Desig : constant Entity_Id := |
| Etype (Designated_Type (RACW_Type)); |
| Stub_Elements : constant Stub_Structure := Stubs_Table.Get (Desig); |
| begin |
| pragma Assert (Stub_Elements /= Empty_Stub_Structure); |
| return Stub_Elements; |
| end Get_Stub_Elements; |
| |
| ----------------------- |
| -- Get_Subprogram_Id -- |
| ----------------------- |
| |
| function Get_Subprogram_Id (Def : Entity_Id) return String_Id is |
| Result : constant String_Id := Get_Subprogram_Ids (Def).Str_Identifier; |
| begin |
| pragma Assert (Result /= No_String); |
| return Result; |
| end Get_Subprogram_Id; |
| |
| ----------------------- |
| -- Get_Subprogram_Id -- |
| ----------------------- |
| |
| function Get_Subprogram_Id (Def : Entity_Id) return Int is |
| begin |
| return Get_Subprogram_Ids (Def).Int_Identifier; |
| end Get_Subprogram_Id; |
| |
| ------------------------ |
| -- Get_Subprogram_Ids -- |
| ------------------------ |
| |
| function Get_Subprogram_Ids |
| (Def : Entity_Id) return Subprogram_Identifiers |
| is |
| begin |
| return Subprogram_Identifier_Table.Get (Def); |
| end Get_Subprogram_Ids; |
| |
| ---------- |
| -- Hash -- |
| ---------- |
| |
| function Hash (F : Entity_Id) return Hash_Index is |
| begin |
| return Hash_Index (Natural (F) mod Positive (Hash_Index'Last + 1)); |
| end Hash; |
| |
| function Hash (F : Name_Id) return Hash_Index is |
| begin |
| return Hash_Index (Integer (F) mod Positive (Hash_Index'Last + 1)); |
| end Hash; |
| |
| -------------------------- |
| -- Input_With_Tag_Check -- |
| -------------------------- |
| |
| function Input_With_Tag_Check |
| (Loc : Source_Ptr; |
| Var_Type : Entity_Id; |
| Stream : Node_Id) return Node_Id |
| is |
| begin |
| return |
| Make_Subprogram_Body (Loc, |
| Specification => |
| Make_Function_Specification (Loc, |
| Defining_Unit_Name => Make_Temporary (Loc, 'S'), |
| Result_Definition => New_Occurrence_Of (Var_Type, Loc)), |
| Declarations => No_List, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, New_List ( |
| Make_Tag_Check (Loc, |
| Make_Simple_Return_Statement (Loc, |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Occurrence_Of (Var_Type, Loc), |
| Attribute_Name => Name_Input, |
| Expressions => |
| New_List (Stream))))))); |
| end Input_With_Tag_Check; |
| |
| -------------------------------- |
| -- Is_RACW_Controlling_Formal -- |
| -------------------------------- |
| |
| function Is_RACW_Controlling_Formal |
| (Parameter : Node_Id; |
| Stub_Type : Entity_Id) return Boolean |
| is |
| Typ : Entity_Id; |
| |
| begin |
| -- If the kind of the parameter is E_Void, then it is not a controlling |
| -- formal (this can happen in the context of RAS). |
| |
| if Ekind (Defining_Identifier (Parameter)) = E_Void then |
| return False; |
| end if; |
| |
| -- If the parameter is not a controlling formal, then it cannot be |
| -- possibly a RACW_Controlling_Formal. |
| |
| if not Is_Controlling_Formal (Defining_Identifier (Parameter)) then |
| return False; |
| end if; |
| |
| Typ := Parameter_Type (Parameter); |
| return (Nkind (Typ) = N_Access_Definition |
| and then Etype (Subtype_Mark (Typ)) = Stub_Type) |
| or else Etype (Typ) = Stub_Type; |
| end Is_RACW_Controlling_Formal; |
| |
| ------------------------------ |
| -- Make_Transportable_Check -- |
| ------------------------------ |
| |
| function Make_Transportable_Check |
| (Loc : Source_Ptr; |
| Expr : Node_Id) return Node_Id is |
| begin |
| return |
| Make_Raise_Program_Error (Loc, |
| Condition => |
| Make_Op_Not (Loc, |
| Build_Get_Transportable (Loc, |
| Make_Selected_Component (Loc, |
| Prefix => Expr, |
| Selector_Name => Make_Identifier (Loc, Name_uTag)))), |
| Reason => PE_Non_Transportable_Actual); |
| end Make_Transportable_Check; |
| |
| ----------------------------- |
| -- Make_Selected_Component -- |
| ----------------------------- |
| |
| function Make_Selected_Component |
| (Loc : Source_Ptr; |
| Prefix : Entity_Id; |
| Selector_Name : Name_Id) return Node_Id |
| is |
| begin |
| return Make_Selected_Component (Loc, |
| Prefix => New_Occurrence_Of (Prefix, Loc), |
| Selector_Name => Make_Identifier (Loc, Selector_Name)); |
| end Make_Selected_Component; |
| |
| -------------------- |
| -- Make_Tag_Check -- |
| -------------------- |
| |
| function Make_Tag_Check (Loc : Source_Ptr; N : Node_Id) return Node_Id is |
| Occ : constant Entity_Id := Make_Temporary (Loc, 'E'); |
| |
| begin |
| return Make_Block_Statement (Loc, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => New_List (N), |
| |
| Exception_Handlers => New_List ( |
| Make_Implicit_Exception_Handler (Loc, |
| Choice_Parameter => Occ, |
| |
| Exception_Choices => |
| New_List (New_Occurrence_Of (RTE (RE_Tag_Error), Loc)), |
| |
| Statements => |
| New_List (Make_Procedure_Call_Statement (Loc, |
| New_Occurrence_Of |
| (RTE (RE_Raise_Program_Error_Unknown_Tag), Loc), |
| New_List (New_Occurrence_Of (Occ, Loc)))))))); |
| end Make_Tag_Check; |
| |
| ---------------------------- |
| -- Need_Extra_Constrained -- |
| ---------------------------- |
| |
| function Need_Extra_Constrained (Parameter : Node_Id) return Boolean is |
| Etyp : constant Entity_Id := Etype (Parameter_Type (Parameter)); |
| begin |
| return Out_Present (Parameter) |
| and then Has_Discriminants (Etyp) |
| and then not Is_Constrained (Etyp) |
| and then Is_Definite_Subtype (Etyp); |
| end Need_Extra_Constrained; |
| |
| ------------------------------------ |
| -- Pack_Entity_Into_Stream_Access -- |
| ------------------------------------ |
| |
| function Pack_Entity_Into_Stream_Access |
| (Loc : Source_Ptr; |
| Stream : Node_Id; |
| Object : Entity_Id; |
| Etyp : Entity_Id := Empty) return Node_Id |
| is |
| Typ : Entity_Id; |
| |
| begin |
| if Present (Etyp) then |
| Typ := Etyp; |
| else |
| Typ := Etype (Object); |
| end if; |
| |
| return |
| Pack_Node_Into_Stream_Access (Loc, |
| Stream => Stream, |
| Object => New_Occurrence_Of (Object, Loc), |
| Etyp => Typ); |
| end Pack_Entity_Into_Stream_Access; |
| |
| --------------------------- |
| -- Pack_Node_Into_Stream -- |
| --------------------------- |
| |
| function Pack_Node_Into_Stream |
| (Loc : Source_Ptr; |
| Stream : Entity_Id; |
| Object : Node_Id; |
| Etyp : Entity_Id) return Node_Id |
| is |
| Write_Attribute : Name_Id := Name_Write; |
| |
| begin |
| if not Is_Constrained (Etyp) then |
| Write_Attribute := Name_Output; |
| end if; |
| |
| return |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Occurrence_Of (Etyp, Loc), |
| Attribute_Name => Write_Attribute, |
| Expressions => New_List ( |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Occurrence_Of (Stream, Loc), |
| Attribute_Name => Name_Access), |
| Object)); |
| end Pack_Node_Into_Stream; |
| |
| ---------------------------------- |
| -- Pack_Node_Into_Stream_Access -- |
| ---------------------------------- |
| |
| function Pack_Node_Into_Stream_Access |
| (Loc : Source_Ptr; |
| Stream : Node_Id; |
| Object : Node_Id; |
| Etyp : Entity_Id) return Node_Id |
| is |
| Write_Attribute : Name_Id := Name_Write; |
| |
| begin |
| if not Is_Constrained (Etyp) then |
| Write_Attribute := Name_Output; |
| end if; |
| |
| return |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Occurrence_Of (Etyp, Loc), |
| Attribute_Name => Write_Attribute, |
| Expressions => New_List ( |
| Stream, |
| Object)); |
| end Pack_Node_Into_Stream_Access; |
| |
| --------------------- |
| -- PolyORB_Support -- |
| --------------------- |
| |
| package body PolyORB_Support is |
| |
| -- Local subprograms |
| |
| procedure Add_RACW_Read_Attribute |
| (RACW_Type : Entity_Id; |
| Stub_Type : Entity_Id; |
| Stub_Type_Access : Entity_Id; |
| Body_Decls : List_Id); |
| -- Add Read attribute for the RACW type. The declaration and attribute |
| -- definition clauses are inserted right after the declaration of |
| -- RACW_Type. If Body_Decls is not No_List, the subprogram body is |
| -- appended to it (case where the RACW declaration is in the main unit). |
| |
| procedure Add_RACW_Write_Attribute |
| (RACW_Type : Entity_Id; |
| Stub_Type : Entity_Id; |
| Stub_Type_Access : Entity_Id; |
| Body_Decls : List_Id); |
| -- Same as above for the Write attribute |
| |
| procedure Add_RACW_From_Any |
| (RACW_Type : Entity_Id; |
| Body_Decls : List_Id); |
| -- Add the From_Any TSS for this RACW type |
| |
| procedure Add_RACW_To_Any |
| (RACW_Type : Entity_Id; |
| Body_Decls : List_Id); |
| -- Add the To_Any TSS for this RACW type |
| |
| procedure Add_RACW_TypeCode |
| (Designated_Type : Entity_Id; |
| RACW_Type : Entity_Id; |
| Body_Decls : List_Id); |
| -- Add the TypeCode TSS for this RACW type |
| |
| procedure Add_RAS_From_Any (RAS_Type : Entity_Id); |
| -- Add the From_Any TSS for this RAS type |
| |
| procedure Add_RAS_To_Any (RAS_Type : Entity_Id); |
| -- Add the To_Any TSS for this RAS type |
| |
| procedure Add_RAS_TypeCode (RAS_Type : Entity_Id); |
| -- Add the TypeCode TSS for this RAS type |
| |
| procedure Add_RAS_Access_TSS (N : Node_Id); |
| -- Add a subprogram body for RAS Access TSS |
| |
| ------------------------------------- |
| -- Add_Obj_RPC_Receiver_Completion -- |
| ------------------------------------- |
| |
| procedure Add_Obj_RPC_Receiver_Completion |
| (Loc : Source_Ptr; |
| Decls : List_Id; |
| RPC_Receiver : Entity_Id; |
| Stub_Elements : Stub_Structure) |
| is |
| Desig : constant Entity_Id := |
| Etype (Designated_Type (Stub_Elements.RACW_Type)); |
| begin |
| Append_To (Decls, |
| Make_Procedure_Call_Statement (Loc, |
| Name => |
| New_Occurrence_Of ( |
| RTE (RE_Register_Obj_Receiving_Stub), Loc), |
| |
| Parameter_Associations => New_List ( |
| |
| -- Name |
| |
| Make_String_Literal (Loc, |
| Fully_Qualified_Name_String (Desig, Append_NUL => False)), |
| |
| -- Handler |
| |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| New_Occurrence_Of ( |
| Defining_Unit_Name (Parent (RPC_Receiver)), Loc), |
| Attribute_Name => |
| Name_Access), |
| |
| -- Receiver |
| |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| New_Occurrence_Of ( |
| Defining_Identifier ( |
| Stub_Elements.RPC_Receiver_Decl), Loc), |
| Attribute_Name => |
| Name_Access)))); |
| end Add_Obj_RPC_Receiver_Completion; |
| |
| ----------------------- |
| -- Add_RACW_Features -- |
| ----------------------- |
| |
| procedure Add_RACW_Features |
| (RACW_Type : Entity_Id; |
| Desig : Entity_Id; |
| Stub_Type : Entity_Id; |
| Stub_Type_Access : Entity_Id; |
| RPC_Receiver_Decl : Node_Id; |
| Body_Decls : List_Id) |
| is |
| pragma Unreferenced (RPC_Receiver_Decl); |
| |
| begin |
| Add_RACW_From_Any |
| (RACW_Type => RACW_Type, |
| Body_Decls => Body_Decls); |
| |
| Add_RACW_To_Any |
| (RACW_Type => RACW_Type, |
| Body_Decls => Body_Decls); |
| |
| Add_RACW_Write_Attribute |
| (RACW_Type => RACW_Type, |
| Stub_Type => Stub_Type, |
| Stub_Type_Access => Stub_Type_Access, |
| Body_Decls => Body_Decls); |
| |
| Add_RACW_Read_Attribute |
| (RACW_Type => RACW_Type, |
| Stub_Type => Stub_Type, |
| Stub_Type_Access => Stub_Type_Access, |
| Body_Decls => Body_Decls); |
| |
| Add_RACW_TypeCode |
| (Designated_Type => Desig, |
| RACW_Type => RACW_Type, |
| Body_Decls => Body_Decls); |
| end Add_RACW_Features; |
| |
| ----------------------- |
| -- Add_RACW_From_Any -- |
| ----------------------- |
| |
| procedure Add_RACW_From_Any |
| (RACW_Type : Entity_Id; |
| Body_Decls : List_Id) |
| is |
| Loc : constant Source_Ptr := Sloc (RACW_Type); |
| Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type); |
| Fnam : constant Entity_Id := |
| Make_Defining_Identifier (Loc, |
| Chars => New_External_Name (Chars (RACW_Type), 'F')); |
| |
| Func_Spec : Node_Id; |
| Func_Decl : Node_Id; |
| Func_Body : Node_Id; |
| |
| Statements : List_Id; |
| -- Various parts of the subprogram |
| |
| Any_Parameter : constant Entity_Id := |
| Make_Defining_Identifier (Loc, Name_A); |
| |
| Asynchronous_Flag : constant Entity_Id := |
| Asynchronous_Flags_Table.Get (RACW_Type); |
| -- The flag object declared in Add_RACW_Asynchronous_Flag |
| |
| begin |
| Func_Spec := |
| Make_Function_Specification (Loc, |
| Defining_Unit_Name => |
| Fnam, |
| Parameter_Specifications => New_List ( |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => |
| Any_Parameter, |
| Parameter_Type => |
| New_Occurrence_Of (RTE (RE_Any), Loc))), |
| Result_Definition => New_Occurrence_Of (RACW_Type, Loc)); |
| |
| -- NOTE: The usage occurrences of RACW_Parameter must refer to the |
| -- entity in the declaration spec, not those of the body spec. |
| |
| Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec); |
| Insert_After (Declaration_Node (RACW_Type), Func_Decl); |
| Set_Renaming_TSS (RACW_Type, Fnam, TSS_From_Any); |
| |
| if No (Body_Decls) then |
| return; |
| end if; |
| |
| -- ??? Issue with asynchronous calls here: the Asynchronous flag is |
| -- set on the stub type if, and only if, the RACW type has a pragma |
| -- Asynchronous. This is incorrect for RACWs that implement RAS |
| -- types, because in that case the /designated subprogram/ (not the |
| -- type) might be asynchronous, and that causes the stub to need to |
| -- be asynchronous too. A solution is to transport a RAS as a struct |
| -- containing a RACW and an asynchronous flag, and to properly alter |
| -- the Asynchronous component in the stub type in the RAS's _From_Any |
| -- TSS. |
| |
| Statements := New_List ( |
| Make_Simple_Return_Statement (Loc, |
| Expression => Unchecked_Convert_To (RACW_Type, |
| Make_Function_Call (Loc, |
| Name => New_Occurrence_Of (RTE (RE_Get_RACW), Loc), |
| Parameter_Associations => New_List ( |
| Make_Function_Call (Loc, |
| Name => New_Occurrence_Of (RTE (RE_FA_ObjRef), Loc), |
| Parameter_Associations => New_List ( |
| New_Occurrence_Of (Any_Parameter, Loc))), |
| Build_Stub_Tag (Loc, RACW_Type), |
| New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc), |
| New_Occurrence_Of (Asynchronous_Flag, Loc)))))); |
| |
| Func_Body := |
| Make_Subprogram_Body (Loc, |
| Specification => Copy_Specification (Loc, Func_Spec), |
| Declarations => No_List, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => Statements)); |
| |
| Append_To (Body_Decls, Func_Body); |
| end Add_RACW_From_Any; |
| |
| ----------------------------- |
| -- Add_RACW_Read_Attribute -- |
| ----------------------------- |
| |
| procedure Add_RACW_Read_Attribute |
| (RACW_Type : Entity_Id; |
| Stub_Type : Entity_Id; |
| Stub_Type_Access : Entity_Id; |
| Body_Decls : List_Id) |
| is |
| pragma Unreferenced (Stub_Type, Stub_Type_Access); |
| |
| Loc : constant Source_Ptr := Sloc (RACW_Type); |
| |
| Proc_Decl : Node_Id; |
| Attr_Decl : Node_Id; |
| |
| Body_Node : Node_Id; |
| |
| Decls : constant List_Id := New_List; |
| Statements : constant List_Id := New_List; |
| Reference : constant Entity_Id := |
| Make_Defining_Identifier (Loc, Name_R); |
| -- Various parts of the procedure |
| |
| Pnam : constant Entity_Id := Make_Temporary (Loc, 'R'); |
| |
| Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type); |
| |
| Asynchronous_Flag : constant Entity_Id := |
| Asynchronous_Flags_Table.Get (RACW_Type); |
| pragma Assert (Present (Asynchronous_Flag)); |
| |
| function Stream_Parameter return Node_Id; |
| function Result return Node_Id; |
| |
| -- Functions to create occurrences of the formal parameter names |
| |
| ------------ |
| -- Result -- |
| ------------ |
| |
| function Result return Node_Id is |
| begin |
| return Make_Identifier (Loc, Name_V); |
| end Result; |
| |
| ---------------------- |
| -- Stream_Parameter -- |
| ---------------------- |
| |
| function Stream_Parameter return Node_Id is |
| begin |
| return Make_Identifier (Loc, Name_S); |
| end Stream_Parameter; |
| |
| -- Start of processing for Add_RACW_Read_Attribute |
| |
| begin |
| Build_Stream_Procedure |
| (Loc, RACW_Type, Body_Node, Pnam, Statements, Outp => True); |
| |
| Proc_Decl := Make_Subprogram_Declaration (Loc, |
| Copy_Specification (Loc, Specification (Body_Node))); |
| |
| Attr_Decl := |
| Make_Attribute_Definition_Clause (Loc, |
| Name => New_Occurrence_Of (RACW_Type, Loc), |
| Chars => Name_Read, |
| Expression => |
| New_Occurrence_Of ( |
| Defining_Unit_Name (Specification (Proc_Decl)), Loc)); |
| |
| Insert_After (Declaration_Node (RACW_Type), Proc_Decl); |
| Insert_After (Proc_Decl, Attr_Decl); |
| |
| if No (Body_Decls) then |
| return; |
| end if; |
| |
| Append_To (Decls, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => |
| Reference, |
| Object_Definition => |
| New_Occurrence_Of (RTE (RE_Object_Ref), Loc))); |
| |
| Append_List_To (Statements, New_List ( |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| New_Occurrence_Of (RTE (RE_Object_Ref), Loc), |
| Attribute_Name => Name_Read, |
| Expressions => New_List ( |
| Stream_Parameter, |
| New_Occurrence_Of (Reference, Loc))), |
| |
| Make_Assignment_Statement (Loc, |
| Name => |
| Result, |
| Expression => |
| Unchecked_Convert_To (RACW_Type, |
| Make_Function_Call (Loc, |
| Name => |
| New_Occurrence_Of (RTE (RE_Get_RACW), Loc), |
| Parameter_Associations => New_List ( |
| New_Occurrence_Of (Reference, Loc), |
| Build_Stub_Tag (Loc, RACW_Type), |
| New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc), |
| New_Occurrence_Of (Asynchronous_Flag, Loc))))))); |
| |
| Set_Declarations (Body_Node, Decls); |
| Append_To (Body_Decls, Body_Node); |
| end Add_RACW_Read_Attribute; |
| |
| --------------------- |
| -- Add_RACW_To_Any -- |
| --------------------- |
| |
| procedure Add_RACW_To_Any |
| (RACW_Type : Entity_Id; |
| Body_Decls : List_Id) |
| is |
| Loc : constant Source_Ptr := Sloc (RACW_Type); |
| |
| Fnam : constant Entity_Id := |
| Make_Defining_Identifier (Loc, |
| Chars => New_External_Name (Chars (RACW_Type), 'T')); |
| |
| Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type); |
| |
| Stub_Elements : constant Stub_Structure := |
| Get_Stub_Elements (RACW_Type); |
| |
| Func_Spec : Node_Id; |
| Func_Decl : Node_Id; |
| Func_Body : Node_Id; |
| |
| Decls : List_Id; |
| Statements : List_Id; |
| -- Various parts of the subprogram |
| |
| RACW_Parameter : constant Entity_Id := |
| Make_Defining_Identifier (Loc, Name_R); |
| |
| Reference : constant Entity_Id := Make_Temporary (Loc, 'R'); |
| Any : constant Entity_Id := Make_Temporary (Loc, 'A'); |
| |
| begin |
| Func_Spec := |
| Make_Function_Specification (Loc, |
| Defining_Unit_Name => |
| Fnam, |
| Parameter_Specifications => New_List ( |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => |
| RACW_Parameter, |
| Parameter_Type => |
| New_Occurrence_Of (RACW_Type, Loc))), |
| Result_Definition => New_Occurrence_Of (RTE (RE_Any), Loc)); |
| |
| -- NOTE: The usage occurrences of RACW_Parameter must refer to the |
| -- entity in the declaration spec, not in the body spec. |
| |
| Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec); |
| |
| Insert_After (Declaration_Node (RACW_Type), Func_Decl); |
| Set_Renaming_TSS (RACW_Type, Fnam, TSS_To_Any); |
| |
| if No (Body_Decls) then |
| return; |
| end if; |
| |
| -- Generate: |
| |
| -- R : constant Object_Ref := |
| -- Get_Reference |
| -- (Address!(RACW), |
| -- "typ", |
| -- Stub_Type'Tag, |
| -- Is_RAS, |
| -- RPC_Receiver'Access); |
| -- A : Any; |
| |
| Decls := New_List ( |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Reference, |
| Constant_Present => True, |
| Object_Definition => |
| New_Occurrence_Of (RTE (RE_Object_Ref), Loc), |
| Expression => |
| Make_Function_Call (Loc, |
| Name => New_Occurrence_Of (RTE (RE_Get_Reference), Loc), |
| Parameter_Associations => New_List ( |
| Unchecked_Convert_To (RTE (RE_Address), |
| New_Occurrence_Of (RACW_Parameter, Loc)), |
| Make_String_Literal (Loc, |
| Strval => Fully_Qualified_Name_String |
| (Etype (Designated_Type (RACW_Type)), |
| Append_NUL => False)), |
| Build_Stub_Tag (Loc, RACW_Type), |
| New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc), |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| New_Occurrence_Of |
| (Defining_Identifier |
| (Stub_Elements.RPC_Receiver_Decl), Loc), |
| Attribute_Name => Name_Access)))), |
| |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Any, |
| Object_Definition => New_Occurrence_Of (RTE (RE_Any), Loc))); |
| |
| -- Generate: |
| |
| -- Any := TA_ObjRef (Reference); |
| -- Set_TC (Any, RPC_Receiver.Obj_TypeCode); |
| -- return Any; |
| |
| Statements := New_List ( |
| Make_Assignment_Statement (Loc, |
| Name => New_Occurrence_Of (Any, Loc), |
| Expression => |
| Make_Function_Call (Loc, |
| Name => New_Occurrence_Of (RTE (RE_TA_ObjRef), Loc), |
| Parameter_Associations => New_List ( |
| New_Occurrence_Of (Reference, Loc)))), |
| |
| Make_Procedure_Call_Statement (Loc, |
| Name => New_Occurrence_Of (RTE (RE_Set_TC), Loc), |
| Parameter_Associations => New_List ( |
| New_Occurrence_Of (Any, Loc), |
| Make_Selected_Component (Loc, |
| Prefix => |
| Defining_Identifier ( |
| Stub_Elements.RPC_Receiver_Decl), |
| Selector_Name => Name_Obj_TypeCode))), |
| |
| Make_Simple_Return_Statement (Loc, |
| Expression => New_Occurrence_Of (Any, Loc))); |
| |
| Func_Body := |
| Make_Subprogram_Body (Loc, |
| Specification => Copy_Specification (Loc, Func_Spec), |
| Declarations => Decls, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => Statements)); |
| Append_To (Body_Decls, Func_Body); |
| end Add_RACW_To_Any; |
| |
| ----------------------- |
| -- Add_RACW_TypeCode -- |
| ----------------------- |
| |
| procedure Add_RACW_TypeCode |
| (Designated_Type : Entity_Id; |
| RACW_Type : Entity_Id; |
| Body_Decls : List_Id) |
| is |
| Loc : constant Source_Ptr := Sloc (RACW_Type); |
| |
| Fnam : constant Entity_Id := |
| Make_Defining_Identifier (Loc, |
| Chars => New_External_Name (Chars (RACW_Type), 'Y')); |
| |
| Stub_Elements : constant Stub_Structure := |
| Stubs_Table.Get (Designated_Type); |
| pragma Assert (Stub_Elements /= Empty_Stub_Structure); |
| |
| Func_Spec : Node_Id; |
| Func_Decl : Node_Id; |
| Func_Body : Node_Id; |
| |
| begin |
| -- The spec for this subprogram has a dummy 'access RACW' argument, |
| -- which serves only for overloading purposes. |
| |
| Func_Spec := |
| Make_Function_Specification (Loc, |
| Defining_Unit_Name => Fnam, |
| Result_Definition => New_Occurrence_Of (RTE (RE_TypeCode), Loc)); |
| |
| -- NOTE: The usage occurrences of RACW_Parameter must refer to the |
| -- entity in the declaration spec, not those of the body spec. |
| |
| Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec); |
| Insert_After (Declaration_Node (RACW_Type), Func_Decl); |
| Set_Renaming_TSS (RACW_Type, Fnam, TSS_TypeCode); |
| |
| if No (Body_Decls) then |
| return; |
| end if; |
| |
| Func_Body := |
| Make_Subprogram_Body (Loc, |
| Specification => Copy_Specification (Loc, Func_Spec), |
| Declarations => Empty_List, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => New_List ( |
| Make_Simple_Return_Statement (Loc, |
| Expression => |
| Make_Selected_Component (Loc, |
| Prefix => |
| Defining_Identifier |
| (Stub_Elements.RPC_Receiver_Decl), |
| Selector_Name => Name_Obj_TypeCode))))); |
| |
| Append_To (Body_Decls, Func_Body); |
| end Add_RACW_TypeCode; |
| |
| ------------------------------ |
| -- Add_RACW_Write_Attribute -- |
| ------------------------------ |
| |
| procedure Add_RACW_Write_Attribute |
| (RACW_Type : Entity_Id; |
| Stub_Type : Entity_Id; |
| Stub_Type_Access : Entity_Id; |
| Body_Decls : List_Id) |
| is |
| pragma Unreferenced (Stub_Type, Stub_Type_Access); |
| |
| Loc : constant Source_Ptr := Sloc (RACW_Type); |
| |
| Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type); |
| |
| Stub_Elements : constant Stub_Structure := |
| Get_Stub_Elements (RACW_Type); |
| |
| Body_Node : Node_Id; |
| Proc_Decl : Node_Id; |
| Attr_Decl : Node_Id; |
| |
| Statements : constant List_Id := New_List; |
| Pnam : constant Entity_Id := Make_Temporary (Loc, 'R'); |
| |
| function Stream_Parameter return Node_Id; |
| function Object return Node_Id; |
| -- Functions to create occurrences of the formal parameter names |
| |
| ------------ |
| -- Object -- |
| ------------ |
| |
| function Object return Node_Id is |
| begin |
| return Make_Identifier (Loc, Name_V); |
| end Object; |
| |
| ---------------------- |
| -- Stream_Parameter -- |
| ---------------------- |
| |
| function Stream_Parameter return Node_Id is |
| begin |
| return Make_Identifier (Loc, Name_S); |
| end Stream_Parameter; |
| |
| -- Start of processing for Add_RACW_Write_Attribute |
| |
| begin |
| Build_Stream_Procedure |
| (Loc, RACW_Type, Body_Node, Pnam, Statements, Outp => False); |
| |
| Proc_Decl := |
| Make_Subprogram_Declaration (Loc, |
| Copy_Specification (Loc, Specification (Body_Node))); |
| |
| Attr_Decl := |
| Make_Attribute_Definition_Clause (Loc, |
| Name => New_Occurrence_Of (RACW_Type, Loc), |
| Chars => Name_Write, |
| Expression => |
| New_Occurrence_Of ( |
| Defining_Unit_Name (Specification (Proc_Decl)), Loc)); |
| |
| Insert_After (Declaration_Node (RACW_Type), Proc_Decl); |
| Insert_After (Proc_Decl, Attr_Decl); |
| |
| if No (Body_Decls) then |
| return; |
| end if; |
| |
| Append_To (Statements, |
| Pack_Node_Into_Stream_Access (Loc, |
| Stream => Stream_Parameter, |
| Object => |
| Make_Function_Call (Loc, |
| Name => New_Occurrence_Of (RTE (RE_Get_Reference), Loc), |
| Parameter_Associations => New_List ( |
| Unchecked_Convert_To (RTE (RE_Address), Object), |
| Make_String_Literal (Loc, |
| Strval => Fully_Qualified_Name_String |
| (Etype (Designated_Type (RACW_Type)), |
| Append_NUL => False)), |
| Build_Stub_Tag (Loc, RACW_Type), |
| New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc), |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| New_Occurrence_Of |
| (Defining_Identifier |
| (Stub_Elements.RPC_Receiver_Decl), Loc), |
| Attribute_Name => Name_Access))), |
| |
| Etyp => RTE (RE_Object_Ref))); |
| |
| Append_To (Body_Decls, Body_Node); |
| end Add_RACW_Write_Attribute; |
| |
| ----------------------- |
| -- Add_RAST_Features -- |
| ----------------------- |
| |
| procedure Add_RAST_Features |
| (Vis_Decl : Node_Id; |
| RAS_Type : Entity_Id) |
| is |
| begin |
| Add_RAS_Access_TSS (Vis_Decl); |
| |
| Add_RAS_From_Any (RAS_Type); |
| Add_RAS_TypeCode (RAS_Type); |
| |
| -- To_Any uses TypeCode, and therefore needs to be generated last |
| |
| Add_RAS_To_Any (RAS_Type); |
| end Add_RAST_Features; |
| |
| ------------------------ |
| -- Add_RAS_Access_TSS -- |
| ------------------------ |
| |
| procedure Add_RAS_Access_TSS (N : Node_Id) is |
| Loc : constant Source_Ptr := Sloc (N); |
| |
| Ras_Type : constant Entity_Id := Defining_Identifier (N); |
| Fat_Type : constant Entity_Id := Equivalent_Type (Ras_Type); |
| -- Ras_Type is the access to subprogram type; Fat_Type is the |
| -- corresponding record type. |
| |
| RACW_Type : constant Entity_Id := |
| Underlying_RACW_Type (Ras_Type); |
| |
| Stub_Elements : constant Stub_Structure := |
| Get_Stub_Elements (RACW_Type); |
| |
| Proc : constant Entity_Id := |
| Make_Defining_Identifier (Loc, |
| Chars => Make_TSS_Name (Ras_Type, TSS_RAS_Access)); |
| |
| Proc_Spec : Node_Id; |
| |
| -- Formal parameters |
| |
| Package_Name : constant Entity_Id := |
| Make_Defining_Identifier (Loc, |
| Chars => Name_P); |
| |
| -- Target package |
| |
| Subp_Id : constant Entity_Id := |
| Make_Defining_Identifier (Loc, |
| Chars => Name_S); |
| |
| -- Target subprogram |
| |
| Asynch_P : constant Entity_Id := |
| Make_Defining_Identifier (Loc, |
| Chars => Name_Asynchronous); |
| -- Is the procedure to which the 'Access applies asynchronous? |
| |
| All_Calls_Remote : constant Entity_Id := |
| Make_Defining_Identifier (Loc, |
| Chars => Name_All_Calls_Remote); |
| -- True if an All_Calls_Remote pragma applies to the RCI unit |
| -- that contains the subprogram. |
| |
| -- Common local variables |
| |
| Proc_Decls : List_Id; |
| Proc_Statements : List_Id; |
| |
| Subp_Ref : constant Entity_Id := |
| Make_Defining_Identifier (Loc, Name_R); |
| -- Reference that designates the target subprogram (returned |
| -- by Get_RAS_Info). |
| |
| Is_Local : constant Entity_Id := |
| Make_Defining_Identifier (Loc, Name_L); |
| Local_Addr : constant Entity_Id := |
| Make_Defining_Identifier (Loc, Name_A); |
| -- For the call to Get_Local_Address |
| |
| Local_Stub : constant Entity_Id := Make_Temporary (Loc, 'L'); |
| Stub_Ptr : constant Entity_Id := Make_Temporary (Loc, 'S'); |
| -- Additional local variables for the remote case |
| |
| function Set_Field |
| (Field_Name : Name_Id; |
| Value : Node_Id) return Node_Id; |
| -- Construct an assignment that sets the named component in the |
| -- returned record |
| |
| --------------- |
| -- Set_Field -- |
| --------------- |
| |
| function Set_Field |
| (Field_Name : Name_Id; |
| Value : Node_Id) return Node_Id |
| is |
| begin |
| return |
| Make_Assignment_Statement (Loc, |
| Name => |
| Make_Selected_Component (Loc, |
| Prefix => Stub_Ptr, |
| Selector_Name => Field_Name), |
| Expression => Value); |
| end Set_Field; |
| |
| -- Start of processing for Add_RAS_Access_TSS |
| |
| begin |
| Proc_Decls := New_List ( |
| |
| -- Common declarations |
| |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Subp_Ref, |
| Object_Definition => |
| New_Occurrence_Of (RTE (RE_Object_Ref), Loc)), |
| |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Is_Local, |
| Object_Definition => |
| New_Occurrence_Of (Standard_Boolean, Loc)), |
| |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Local_Addr, |
| Object_Definition => |
| New_Occurrence_Of (RTE (RE_Address), Loc)), |
| |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Local_Stub, |
| Aliased_Present => True, |
| Object_Definition => |
| New_Occurrence_Of (Stub_Elements.Stub_Type, Loc)), |
| |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Stub_Ptr, |
| Object_Definition => |
| New_Occurrence_Of (Stub_Elements.Stub_Type_Access, Loc), |
| Expression => |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Occurrence_Of (Local_Stub, Loc), |
| Attribute_Name => Name_Unchecked_Access))); |
| |
| Set_Etype (Stub_Ptr, Stub_Elements.Stub_Type_Access); |
| -- Build_Get_Unique_RP_Call needs this information |
| |
| -- Get_RAS_Info (Pkg, Subp, R); |
| -- Obtain a reference to the target subprogram |
| |
| Proc_Statements := New_List ( |
| Make_Procedure_Call_Statement (Loc, |
| Name => New_Occurrence_Of (RTE (RE_Get_RAS_Info), Loc), |
| Parameter_Associations => New_List ( |
| New_Occurrence_Of (Package_Name, Loc), |
| New_Occurrence_Of (Subp_Id, Loc), |
| New_Occurrence_Of (Subp_Ref, Loc))), |
| |
| -- Get_Local_Address (R, L, A); |
| -- Determine whether the subprogram is local (L), and if so |
| -- obtain the local address of its proxy (A). |
| |
| Make_Procedure_Call_Statement (Loc, |
| Name => New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc), |
| Parameter_Associations => New_List ( |
| New_Occurrence_Of (Subp_Ref, Loc), |
| New_Occurrence_Of (Is_Local, Loc), |
| New_Occurrence_Of (Local_Addr, Loc)))); |
| |
| -- Note: Here we assume that the Fat_Type is a record containing just |
| -- an access to a proxy or stub object. |
| |
| Append_To (Proc_Statements, |
| |
| -- if L then |
| |
| Make_Implicit_If_Statement (N, |
| Condition => New_Occurrence_Of (Is_Local, Loc), |
| |
| Then_Statements => New_List ( |
| |
| -- if A.Target = null then |
| |
| Make_Implicit_If_Statement (N, |
| Condition => |
| Make_Op_Eq (Loc, |
| Make_Selected_Component (Loc, |
| Prefix => |
| Unchecked_Convert_To |
| (RTE (RE_RAS_Proxy_Type_Access), |
| New_Occurrence_Of (Local_Addr, Loc)), |
| Selector_Name => Make_Identifier (Loc, Name_Target)), |
| Make_Null (Loc)), |
| |
| Then_Statements => New_List ( |
| |
| -- A.Target := Entity_Of (Ref); |
| |
| Make_Assignment_Statement (Loc, |
| Name => |
| Make_Selected_Component (Loc, |
| Prefix => |
| Unchecked_Convert_To |
| (RTE (RE_RAS_Proxy_Type_Access), |
| New_Occurrence_Of (Local_Addr, Loc)), |
| Selector_Name => Make_Identifier (Loc, Name_Target)), |
| Expression => |
| Make_Function_Call (Loc, |
| Name => New_Occurrence_Of (RTE (RE_Entity_Of), Loc), |
| Parameter_Associations => New_List ( |
| New_Occurrence_Of (Subp_Ref, Loc)))), |
| |
| -- Inc_Usage (A.Target); |
| -- end if; |
| |
| Make_Procedure_Call_Statement (Loc, |
| Name => New_Occurrence_Of (RTE (RE_Inc_Usage), Loc), |
| Parameter_Associations => New_List ( |
| Make_Selected_Component (Loc, |
| Prefix => |
| Unchecked_Convert_To |
| (RTE (RE_RAS_Proxy_Type_Access), |
| New_Occurrence_Of (Local_Addr, Loc)), |
| Selector_Name => |
| Make_Identifier (Loc, Name_Target)))))), |
| |
| -- if not All_Calls_Remote then |
| -- return Fat_Type!(A); |
| -- end if; |
| |
| Make_Implicit_If_Statement (N, |
| Condition => |
| Make_Op_Not (Loc, |
| Right_Opnd => |
| New_Occurrence_Of (All_Calls_Remote, Loc)), |
| |
| Then_Statements => New_List ( |
| Make_Simple_Return_Statement (Loc, |
| Expression => |
| Unchecked_Convert_To |
| (Fat_Type, New_Occurrence_Of (Local_Addr, Loc)))))))); |
| |
| Append_List_To (Proc_Statements, New_List ( |
| |
| -- Stub.Target := Entity_Of (Ref); |
| |
| Set_Field (Name_Target, |
| Make_Function_Call (Loc, |
| Name => New_Occurrence_Of (RTE (RE_Entity_Of), Loc), |
| Parameter_Associations => New_List ( |
| New_Occurrence_Of (Subp_Ref, Loc)))), |
| |
| -- Inc_Usage (Stub.Target); |
| |
| Make_Procedure_Call_Statement (Loc, |
| Name => New_Occurrence_Of (RTE (RE_Inc_Usage), Loc), |
| Parameter_Associations => New_List ( |
| Make_Selected_Component (Loc, |
| Prefix => Stub_Ptr, |
| Selector_Name => Name_Target))), |
| |
| -- E.4.1(9) A remote call is asynchronous if it is a call to |
| -- a procedure, or a call through a value of an access-to-procedure |
| -- type, to which a pragma Asynchronous applies. |
| |
| -- Parameter Asynch_P is true when the procedure is asynchronous; |
| -- Expression Asynch_T is true when the type is asynchronous. |
| |
| Set_Field (Name_Asynchronous, |
| Make_Or_Else (Loc, |
| Left_Opnd => New_Occurrence_Of (Asynch_P, Loc), |
| Right_Opnd => |
| New_Occurrence_Of |
| (Boolean_Literals (Is_Asynchronous (Ras_Type)), Loc))))); |
| |
| Append_List_To (Proc_Statements, |
| Build_Get_Unique_RP_Call (Loc, Stub_Ptr, Stub_Elements.Stub_Type)); |
| |
| Append_To (Proc_Statements, |
| Make_Simple_Return_Statement (Loc, |
| Expression => |
| Unchecked_Convert_To (Fat_Type, |
| New_Occurrence_Of (Stub_Ptr, Loc)))); |
| |
| Proc_Spec := |
| Make_Function_Specification (Loc, |
| Defining_Unit_Name => Proc, |
| Parameter_Specifications => New_List ( |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => Package_Name, |
| Parameter_Type => |
| New_Occurrence_Of (Standard_String, Loc)), |
| |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => Subp_Id, |
| Parameter_Type => |
| New_Occurrence_Of (Standard_String, Loc)), |
| |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => Asynch_P, |
| Parameter_Type => |
| New_Occurrence_Of (Standard_Boolean, Loc)), |
| |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => All_Calls_Remote, |
| Parameter_Type => |
| New_Occurrence_Of (Standard_Boolean, Loc))), |
| |
| Result_Definition => |
| New_Occurrence_Of (Fat_Type, Loc)); |
| |
| -- Set the kind and return type of the function to prevent |
| -- ambiguities between Ras_Type and Fat_Type in subsequent analysis. |
| |
| Mutate_Ekind (Proc, E_Function); |
| Set_Etype (Proc, Fat_Type); |
| |
| Discard_Node ( |
| Make_Subprogram_Body (Loc, |
| Specification => Proc_Spec, |
| Declarations => Proc_Decls, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => Proc_Statements))); |
| |
| Set_TSS (Fat_Type, Proc); |
| end Add_RAS_Access_TSS; |
| |
| ---------------------- |
| -- Add_RAS_From_Any -- |
| ---------------------- |
| |
| procedure Add_RAS_From_Any (RAS_Type : Entity_Id) is |
| Loc : constant Source_Ptr := Sloc (RAS_Type); |
| |
| Fnam : constant Entity_Id := Make_Defining_Identifier (Loc, |
| Make_TSS_Name (RAS_Type, TSS_From_Any)); |
| |
| Func_Spec : Node_Id; |
| |
| Statements : List_Id; |
| |
| Any_Parameter : constant Entity_Id := |
| Make_Defining_Identifier (Loc, Name_A); |
| |
| begin |
| Statements := New_List ( |
| Make_Simple_Return_Statement (Loc, |
| Expression => |
| Make_Aggregate (Loc, |
| Component_Associations => New_List ( |
| Make_Component_Association (Loc, |
| Choices => New_List (Make_Identifier (Loc, Name_Ras)), |
| Expression => |
| PolyORB_Support.Helpers.Build_From_Any_Call |
| (Underlying_RACW_Type (RAS_Type), |
| New_Occurrence_Of (Any_Parameter, Loc), |
| No_List)))))); |
| |
| Func_Spec := |
| Make_Function_Specification (Loc, |
| Defining_Unit_Name => Fnam, |
| Parameter_Specifications => New_List ( |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => Any_Parameter, |
| Parameter_Type => New_Occurrence_Of (RTE (RE_Any), Loc))), |
| Result_Definition => New_Occurrence_Of (RAS_Type, Loc)); |
| |
| Discard_Node ( |
| Make_Subprogram_Body (Loc, |
| Specification => Func_Spec, |
| Declarations => No_List, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => Statements))); |
| Set_TSS (RAS_Type, Fnam); |
| end Add_RAS_From_Any; |
| |
| -------------------- |
| -- Add_RAS_To_Any -- |
| -------------------- |
| |
| procedure Add_RAS_To_Any (RAS_Type : Entity_Id) is |
| Loc : constant Source_Ptr := Sloc (RAS_Type); |
| |
| Fnam : constant Entity_Id := Make_Defining_Identifier (Loc, |
| Make_TSS_Name (RAS_Type, TSS_To_Any)); |
| |
| Decls : List_Id; |
| Statements : List_Id; |
| |
| Func_Spec : Node_Id; |
| |
| Any : constant Entity_Id := Make_Temporary (Loc, 'A'); |
| RAS_Parameter : constant Entity_Id := Make_Temporary (Loc, 'R'); |
| RACW_Parameter : constant Node_Id := |
| Make_Selected_Component (Loc, |
| Prefix => RAS_Parameter, |
| Selector_Name => Name_Ras); |
| |
| begin |
| -- Object declarations |
| |
| Set_Etype (RACW_Parameter, Underlying_RACW_Type (RAS_Type)); |
| Decls := New_List ( |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Any, |
| Object_Definition => New_Occurrence_Of (RTE (RE_Any), Loc), |
| Expression => |
| PolyORB_Support.Helpers.Build_To_Any_Call |
| (Loc, RACW_Parameter, No_List))); |
| |
| Statements := New_List ( |
| Make_Procedure_Call_Statement (Loc, |
| Name => New_Occurrence_Of (RTE (RE_Set_TC), Loc), |
| Parameter_Associations => New_List ( |
| New_Occurrence_Of (Any, Loc), |
| PolyORB_Support.Helpers.Build_TypeCode_Call (Loc, |
| RAS_Type, Decls))), |
| |
| Make_Simple_Return_Statement (Loc, |
| Expression => New_Occurrence_Of (Any, Loc))); |
| |
| Func_Spec := |
| Make_Function_Specification (Loc, |
| Defining_Unit_Name => Fnam, |
| Parameter_Specifications => New_List ( |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => RAS_Parameter, |
| Parameter_Type => New_Occurrence_Of (RAS_Type, Loc))), |
| Result_Definition => New_Occurrence_Of (RTE (RE_Any), Loc)); |
| |
| Discard_Node ( |
| Make_Subprogram_Body (Loc, |
| Specification => Func_Spec, |
| Declarations => Decls, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => Statements))); |
| Set_TSS (RAS_Type, Fnam); |
| end Add_RAS_To_Any; |
| |
| ---------------------- |
| -- Add_RAS_TypeCode -- |
| ---------------------- |
| |
| procedure Add_RAS_TypeCode (RAS_Type : Entity_Id) is |
| Loc : constant Source_Ptr := Sloc (RAS_Type); |
| |
| Fnam : constant Entity_Id := Make_Defining_Identifier (Loc, |
| Make_TSS_Name (RAS_Type, TSS_TypeCode)); |
| |
| Func_Spec : Node_Id; |
| Decls : constant List_Id := New_List; |
| Name_String : String_Id; |
| Repo_Id_String : String_Id; |
| |
| begin |
| Func_Spec := |
| Make_Function_Specification (Loc, |
| Defining_Unit_Name => Fnam, |
| Result_Definition => New_Occurrence_Of (RTE (RE_TypeCode), Loc)); |
| |
| PolyORB_Support.Helpers.Build_Name_And_Repository_Id |
| (RAS_Type, Name_Str => Name_String, Repo_Id_Str => Repo_Id_String); |
| |
| Discard_Node ( |
| Make_Subprogram_Body (Loc, |
| Specification => Func_Spec, |
| Declarations => Decls, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => New_List ( |
| Make_Simple_Return_Statement (Loc, |
| Expression => |
| Make_Function_Call (Loc, |
| Name => |
| New_Occurrence_Of (RTE (RE_Build_Complex_TC), Loc), |
| Parameter_Associations => New_List ( |
| New_Occurrence_Of (RTE (RE_Tk_Objref), Loc), |
| Make_Aggregate (Loc, |
| Expressions => |
| New_List ( |
| Make_Function_Call (Loc, |
| Name => |
| New_Occurrence_Of |
| (RTE (RE_TA_Std_String), Loc), |
| Parameter_Associations => New_List ( |
| Make_String_Literal (Loc, Name_String))), |
| Make_Function_Call (Loc, |
| Name => |
| New_Occurrence_Of |
| (RTE (RE_TA_Std_String), Loc), |
| Parameter_Associations => New_List ( |
| Make_String_Literal (Loc, |
| Strval => Repo_Id_String)))))))))))); |
| Set_TSS (RAS_Type, Fnam); |
| end Add_RAS_TypeCode; |
| |
| ----------------------------------------- |
| -- Add_Receiving_Stubs_To_Declarations -- |
| ----------------------------------------- |
| |
| procedure Add_Receiving_Stubs_To_Declarations |
| (Pkg_Spec : Node_Id; |
| Decls : List_Id; |
| Stmts : List_Id) |
| is |
| Loc : constant Source_Ptr := Sloc (Pkg_Spec); |
| |
| Pkg_RPC_Receiver : constant Entity_Id := |
| Make_Temporary (Loc, 'H'); |
| Pkg_RPC_Receiver_Object : Node_Id; |
| Pkg_RPC_Receiver_Body : Node_Id; |
| Pkg_RPC_Receiver_Decls : List_Id; |
| Pkg_RPC_Receiver_Statements : List_Id; |
| |
| Pkg_RPC_Receiver_Cases : constant List_Id := New_List; |
| -- A Pkg_RPC_Receiver is built to decode the request |
| |
| Request : Node_Id; |
| -- Request object received from neutral layer |
| |
| Subp_Id : Entity_Id; |
| -- Subprogram identifier as received from the neutral distribution |
| -- core. |
| |
| Subp_Index : Entity_Id; |
| -- Internal index as determined by matching either the method name |
| -- from the request structure, or the local subprogram address (in |
| -- case of a RAS). |
| |
| Is_Local : constant Entity_Id := Make_Temporary (Loc, 'L'); |
| |
| Local_Address : constant Entity_Id := Make_Temporary (Loc, 'A'); |
| -- Address of a local subprogram designated by a reference |
| -- corresponding to a RAS. |
| |
| Dispatch_On_Address : constant List_Id := New_List; |
| Dispatch_On_Name : constant List_Id := New_List; |
| |
| Current_Subp_Number : Int := First_RCI_Subprogram_Id; |
| |
| Subp_Info_Array : constant Entity_Id := Make_Temporary (Loc, 'I'); |
| Subp_Info_List : constant List_Id := New_List; |
| |
| Register_Pkg_Actuals : constant List_Id := New_List; |
| |
| All_Calls_Remote_E : Entity_Id; |
| |
| procedure Append_Stubs_To |
| (RPC_Receiver_Cases : List_Id; |
| Declaration : Node_Id; |
| Stubs : Node_Id; |
| Subp_Number : Int; |
| Subp_Dist_Name : Entity_Id; |
| Subp_Proxy_Addr : Entity_Id); |
| -- Add one case to the specified RPC receiver case list associating |
| -- Subprogram_Number with the subprogram declared by Declaration, for |
| -- which we have receiving stubs in Stubs. Subp_Number is an internal |
| -- subprogram index. Subp_Dist_Name is the string used to call the |
| -- subprogram by name, and Subp_Dist_Addr is the address of the proxy |
| -- object, used in the context of calls through remote |
| -- access-to-subprogram types. |
| |
| procedure Visit_Subprogram (Decl : Node_Id); |
| -- Generate receiving stub for one remote subprogram |
| |
| --------------------- |
| -- Append_Stubs_To -- |
| --------------------- |
| |
| procedure Append_Stubs_To |
| (RPC_Receiver_Cases : List_Id; |
| Declaration : Node_Id; |
| Stubs : Node_Id; |
| Subp_Number : Int; |
| Subp_Dist_Name : Entity_Id; |
| Subp_Proxy_Addr : Entity_Id) |
| is |
| Case_Stmts : List_Id; |
| begin |
| Case_Stmts := New_List ( |
| Make_Procedure_Call_Statement (Loc, |
| Name => |
| New_Occurrence_Of ( |
| Defining_Entity (Stubs), Loc), |
| Parameter_Associations => |
| New_List (New_Occurrence_Of (Request, Loc)))); |
| |
| if Nkind (Specification (Declaration)) = N_Function_Specification |
| or else not |
| Is_Asynchronous (Defining_Entity (Specification (Declaration))) |
| then |
| Append_To (Case_Stmts, Make_Simple_Return_Statement (Loc)); |
| end if; |
| |
| Append_To (RPC_Receiver_Cases, |
| Make_Case_Statement_Alternative (Loc, |
| Discrete_Choices => |
| New_List (Make_Integer_Literal (Loc, Subp_Number)), |
| Statements => Case_Stmts)); |
| |
| Append_To (Dispatch_On_Name, |
| Make_Elsif_Part (Loc, |
| Condition => |
| Make_Function_Call (Loc, |
| Name => |
| New_Occurrence_Of (RTE (RE_Caseless_String_Eq), Loc), |
| Parameter_Associations => New_List ( |
| New_Occurrence_Of (Subp_Id, Loc), |
| New_Occurrence_Of (Subp_Dist_Name, Loc))), |
| |
| Then_Statements => New_List ( |
| Make_Assignment_Statement (Loc, |
| New_Occurrence_Of (Subp_Index, Loc), |
| Make_Integer_Literal (Loc, Subp_Number))))); |
| |
| Append_To (Dispatch_On_Address, |
| Make_Elsif_Part (Loc, |
| Condition => |
| Make_Op_Eq (Loc, |
| Left_Opnd => New_Occurrence_Of (Local_Address, Loc), |
| Right_Opnd => New_Occurrence_Of (Subp_Proxy_Addr, Loc)), |
| |
| Then_Statements => New_List ( |
| Make_Assignment_Statement (Loc, |
| New_Occurrence_Of (Subp_Index, Loc), |
| Make_Integer_Literal (Loc, Subp_Number))))); |
| end Append_Stubs_To; |
| |
| ---------------------- |
| -- Visit_Subprogram -- |
| ---------------------- |
| |
| procedure Visit_Subprogram (Decl : Node_Id) is |
| Loc : constant Source_Ptr := Sloc (Decl); |
| Spec : constant Node_Id := Specification (Decl); |
| Subp_Def : constant Entity_Id := Defining_Unit_Name (Spec); |
| |
| Subp_Val : String_Id; |
| |
| Subp_Dist_Name : constant Entity_Id := |
| Make_Defining_Identifier (Loc, |
| Chars => |
| New_External_Name |
| (Related_Id => Chars (Subp_Def), |
| Suffix => 'D', |
| Suffix_Index => -1)); |
| |
| Current_Stubs : Node_Id; |
| Proxy_Obj_Addr : Entity_Id; |
| |
| begin |
| -- Disable expansion of stubs if serious errors have been |
| -- diagnosed, because otherwise some illegal remote subprogram |
| -- declarations could cause cascaded errors in stubs. |
| |
| if Serious_Errors_Detected /= 0 then |
| return; |
| end if; |
| |
| -- Build receiving stub |
| |
| Current_Stubs := |
| Build_Subprogram_Receiving_Stubs |
| (Vis_Decl => Decl, |
| Asynchronous => Nkind (Spec) = N_Procedure_Specification |
| and then Is_Asynchronous (Subp_Def)); |
| |
| Append_To (Decls, Current_Stubs); |
| Analyze (Current_Stubs); |
| |
| -- Build RAS proxy |
| |
| Add_RAS_Proxy_And_Analyze (Decls, |
| Vis_Decl => Decl, |
| All_Calls_Remote_E => All_Calls_Remote_E, |
| Proxy_Object_Addr => Proxy_Obj_Addr); |
| |
| -- Compute distribution identifier |
| |
| Assign_Subprogram_Identifier |
| (Subp_Def, Current_Subp_Number, Subp_Val); |
| |
| pragma Assert |
| (Current_Subp_Number = Get_Subprogram_Id (Subp_Def)); |
| |
| Append_To (Decls, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Subp_Dist_Name, |
| Constant_Present => True, |
| Object_Definition => |
| New_Occurrence_Of (Standard_String, Loc), |
| Expression => |
| Make_String_Literal (Loc, Subp_Val))); |
| Analyze (Last (Decls)); |
| |
| -- Add subprogram descriptor (RCI_Subp_Info) to the subprograms |
| -- table for this receiver. The aggregate below must be kept |
| -- consistent with the declaration of RCI_Subp_Info in |
| -- System.Partition_Interface. |
| |
| Append_To (Subp_Info_List, |
| Make_Component_Association (Loc, |
| Choices => |
| New_List (Make_Integer_Literal (Loc, Current_Subp_Number)), |
| |
| Expression => |
| Make_Aggregate (Loc, |
| Expressions => New_List ( |
| |
| -- Name => |
| |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| New_Occurrence_Of (Subp_Dist_Name, Loc), |
| Attribute_Name => Name_Address), |
| |
| -- Name_Length => |
| |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| New_Occurrence_Of (Subp_Dist_Name, Loc), |
| Attribute_Name => Name_Length), |
| |
| -- Addr => |
| |
| New_Occurrence_Of (Proxy_Obj_Addr, Loc))))); |
| |
| Append_Stubs_To (Pkg_RPC_Receiver_Cases, |
| Declaration => Decl, |
| Stubs => Current_Stubs, |
| Subp_Number => Current_Subp_Number, |
| Subp_Dist_Name => Subp_Dist_Name, |
| Subp_Proxy_Addr => Proxy_Obj_Addr); |
| |
| Current_Subp_Number := Current_Subp_Number + 1; |
| end Visit_Subprogram; |
| |
| procedure Visit_Spec is new Build_Package_Stubs (Visit_Subprogram); |
| |
| -- Start of processing for Add_Receiving_Stubs_To_Declarations |
| |
| begin |
| -- Building receiving stubs consist in several operations: |
| |
| -- - a package RPC receiver must be built. This subprogram will get |
| -- a Subprogram_Id from the incoming stream and will dispatch the |
| -- call to the right subprogram; |
| |
| -- - a receiving stub for each subprogram visible in the package |
| -- spec. This stub will read all the parameters from the stream, |
| -- and put the result as well as the exception occurrence in the |
| -- output stream; |
| |
| Build_RPC_Receiver_Body ( |
| RPC_Receiver => Pkg_RPC_Receiver, |
| Request => Request, |
| Subp_Id => Subp_Id, |
| Subp_Index => Subp_Index, |
| Stmts => Pkg_RPC_Receiver_Statements, |
| Decl => Pkg_RPC_Receiver_Body); |
| Pkg_RPC_Receiver_Decls := Declarations (Pkg_RPC_Receiver_Body); |
| |
| -- Extract local address information from the target reference: |
| -- if non-null, that means that this is a reference that denotes |
| -- one particular operation, and hence that the operation name |
| -- must not be taken into account for dispatching. |
| |
| Append_To (Pkg_RPC_Receiver_Decls, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Is_Local, |
| Object_Definition => |
| New_Occurrence_Of (Standard_Boolean, Loc))); |
| |
| Append_To (Pkg_RPC_Receiver_Decls, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Local_Address, |
| Object_Definition => |
| New_Occurrence_Of (RTE (RE_Address), Loc))); |
| |
| Append_To (Pkg_RPC_Receiver_Statements, |
| Make_Procedure_Call_Statement (Loc, |
| Name => New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc), |
| Parameter_Associations => New_List ( |
| Make_Selected_Component (Loc, |
| Prefix => Request, |
| Selector_Name => Name_Target), |
| New_Occurrence_Of (Is_Local, Loc), |
| New_Occurrence_Of (Local_Address, Loc)))); |
| |
| -- For each subprogram, the receiving stub will be built and a case |
| -- statement will be made on the Subprogram_Id to dispatch to the |
| -- right subprogram. |
| |
| All_Calls_Remote_E := Boolean_Literals ( |
| Has_All_Calls_Remote (Defining_Entity (Pkg_Spec))); |
| |
| Overload_Counter_Table.Reset; |
| Reserve_NamingContext_Methods; |
| |
| Visit_Spec (Pkg_Spec); |
| |
| Append_To (Decls, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Subp_Info_Array, |
| Constant_Present => True, |
| Aliased_Present => True, |
| Object_Definition => |
| Make_Subtype_Indication (Loc, |
| Subtype_Mark => |
| New_Occurrence_Of (RTE (RE_RCI_Subp_Info_Array), Loc), |
| Constraint => |
| Make_Index_Or_Discriminant_Constraint (Loc, |
| New_List ( |
| Make_Range (Loc, |
| Low_Bound => |
| Make_Integer_Literal (Loc, |
| Intval => First_RCI_Subprogram_Id), |
| High_Bound => |
| Make_Integer_Literal (Loc, |
| Intval => |
| First_RCI_Subprogram_Id |
| + List_Length (Subp_Info_List) - 1))))))); |
| |
| if Present (First (Subp_Info_List)) then |
| Set_Expression (Last (Decls), |
| Make_Aggregate (Loc, |
| Component_Associations => Subp_Info_List)); |
| |
| -- Generate the dispatch statement to determine the subprogram id |
| -- of the called subprogram. |
| |
| -- We first test whether the reference that was used to make the |
| -- call was the base RCI reference (in which case Local_Address is |
| -- zero, and the method identifier from the request must be used |
| -- to determine which subprogram is called) or a reference |
| -- identifying one particular subprogram (in which case |
| -- Local_Address is the address of that subprogram, and the |
| -- method name from the request is ignored). The latter occurs |
| -- for the case of a call through a remote access-to-subprogram. |
| |
| -- In each case, cascaded elsifs are used to determine the proper |
| -- subprogram index. Using hash tables might be more efficient. |
| |
| Append_To (Pkg_RPC_Receiver_Statements, |
| Make_Implicit_If_Statement (Pkg_Spec, |
| Condition => |
| Make_Op_Ne (Loc, |
| Left_Opnd => New_Occurrence_Of (Local_Address, Loc), |
| Right_Opnd => New_Occurrence_Of |
| (RTE (RE_Null_Address), Loc)), |
| |
| Then_Statements => New_List ( |
| Make_Implicit_If_Statement (Pkg_Spec, |
| Condition => New_Occurrence_Of (Standard_False, Loc), |
| Then_Statements => New_List ( |
| Make_Null_Statement (Loc)), |
| Elsif_Parts => Dispatch_On_Address)), |
| |
| Else_Statements => New_List ( |
| Make_Implicit_If_Statement (Pkg_Spec, |
| Condition => New_Occurrence_Of (Standard_False, Loc), |
| Then_Statements => New_List (Make_Null_Statement (Loc)), |
| Elsif_Parts => Dispatch_On_Name)))); |
| |
| else |
| -- For a degenerate RCI with no visible subprograms, |
| -- Subp_Info_List has zero length, and the declaration is for an |
| -- empty array, in which case no initialization aggregate must be |
| -- generated. We do not generate a Dispatch_Statement either. |
| |
| -- No initialization provided: remove CONSTANT so that the |
| -- declaration is not an incomplete deferred constant. |
| |
| Set_Constant_Present (Last (Decls), False); |
| end if; |
| |
| -- Analyze Subp_Info_Array declaration |
| |
| Analyze (Last (Decls)); |
| |
| -- If we receive an invalid Subprogram_Id, it is best to do nothing |
| -- rather than raising an exception since we do not want someone |
| -- to crash a remote partition by sending invalid subprogram ids. |
| -- This is consistent with the other parts of the case statement |
| -- since even in presence of incorrect parameters in the stream, |
| -- every exception will be caught and (if the subprogram is not an |
| -- APC) put into the result stream and sent away. |
| |
| Append_To (Pkg_RPC_Receiver_Cases, |
| Make_Case_Statement_Alternative (Loc, |
| Discrete_Choices => New_List (Make_Others_Choice (Loc)), |
| Statements => New_List (Make_Null_Statement (Loc)))); |
| |
| Append_To (Pkg_RPC_Receiver_Statements, |
| Make_Case_Statement (Loc, |
| Expression => New_Occurrence_Of (Subp_Index, Loc), |
| Alternatives => Pkg_RPC_Receiver_Cases)); |
| |
| -- Pkg_RPC_Receiver body is now complete: insert it into the tree and |
| -- analyze it. |
| |
| Append_To (Decls, Pkg_RPC_Receiver_Body); |
| Analyze (Last (Decls)); |
| |
| Pkg_RPC_Receiver_Object := |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Make_Temporary (Loc, 'R'), |
| Aliased_Present => True, |
| Object_Definition => New_Occurrence_Of (RTE (RE_Servant), Loc)); |
| Append_To (Decls, Pkg_RPC_Receiver_Object); |
| Analyze (Last (Decls)); |
| |
| -- Name |
| |
| Append_To (Register_Pkg_Actuals, |
| Make_String_Literal (Loc, |
| Strval => |
| Fully_Qualified_Name_String |
| (Defining_Entity (Pkg_Spec), Append_NUL => False))); |
| |
| -- Version |
| |
| Append_To (Register_Pkg_Actuals, |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| New_Occurrence_Of |
| (Defining_Entity (Pkg_Spec), Loc), |
| Attribute_Name => Name_Version)); |
| |
| -- Handler |
| |
| Append_To (Register_Pkg_Actuals, |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| New_Occurrence_Of (Pkg_RPC_Receiver, Loc), |
| Attribute_Name => Name_Access)); |
| |
| -- Receiver |
| |
| Append_To (Register_Pkg_Actuals, |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| New_Occurrence_Of ( |
| Defining_Identifier (Pkg_RPC_Receiver_Object), Loc), |
| Attribute_Name => Name_Access)); |
| |
| -- Subp_Info |
| |
| Append_To (Register_Pkg_Actuals, |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Occurrence_Of (Subp_Info_Array, Loc), |
| Attribute_Name => Name_Address)); |
| |
| -- Subp_Info_Len |
| |
| Append_To (Register_Pkg_Actuals, |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Occurrence_Of (Subp_Info_Array, Loc), |
| Attribute_Name => Name_Length)); |
| |
| -- Is_All_Calls_Remote |
| |
| Append_To (Register_Pkg_Actuals, |
| New_Occurrence_Of (All_Calls_Remote_E, Loc)); |
| |
| -- Finally call Register_Pkg_Receiving_Stub with the above parameters |
| |
| Append_To (Stmts, |
| Make_Procedure_Call_Statement (Loc, |
| Name => |
| New_Occurrence_Of (RTE (RE_Register_Pkg_Receiving_Stub), Loc), |
| Parameter_Associations => Register_Pkg_Actuals)); |
| Analyze (Last (Stmts)); |
| end Add_Receiving_Stubs_To_Declarations; |
| |
| --------------------------------- |
| -- Build_General_Calling_Stubs -- |
| --------------------------------- |
| |
| procedure Build_General_Calling_Stubs |
| (Decls : List_Id; |
| Statements : List_Id; |
| Target_Object : Node_Id; |
| Subprogram_Id : Node_Id; |
| Asynchronous : Node_Id := Empty; |
| Is_Known_Asynchronous : Boolean := False; |
| Is_Known_Non_Asynchronous : Boolean := False; |
| Is_Function : Boolean; |
| Spec : Node_Id; |
| Stub_Type : Entity_Id := Empty; |
| RACW_Type : Entity_Id := Empty; |
| Nod : Node_Id) |
| is |
| Loc : constant Source_Ptr := Sloc (Nod); |
| |
| Request : constant Entity_Id := Make_Temporary (Loc, 'R'); |
| -- The request object constructed by these stubs |
| -- Could we use Name_R instead??? (see GLADE client stubs) |
| |
| function Make_Request_RTE_Call |
| (RE : RE_Id; |
| Actuals : List_Id := New_List) return Node_Id; |
| -- Generate a procedure call statement calling RE with the given |
| -- actuals. Request'Access is appended to the list. |
| |
| --------------------------- |
| -- Make_Request_RTE_Call -- |
| --------------------------- |
| |
| function Make_Request_RTE_Call |
| (RE : RE_Id; |
| Actuals : List_Id := New_List) return Node_Id |
| is |
| begin |
| Append_To (Actuals, |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Occurrence_Of (Request, Loc), |
| Attribute_Name => Name_Access)); |
| return Make_Procedure_Call_Statement (Loc, |
| Name => |
| New_Occurrence_Of (RTE (RE), Loc), |
| Parameter_Associations => Actuals); |
| end Make_Request_RTE_Call; |
| |
| Arguments : Node_Id; |
| -- Name of the named values list used to transmit parameters |
| -- to the remote package |
| |
| Result : Node_Id; |
| -- Name of the result named value (in non-APC cases) which get the |
| -- result of the remote subprogram. |
| |
| Result_TC : Node_Id; |
| -- Typecode expression for the result of the request (void |
| -- typecode for procedures). |
| |
| Exception_Return_Parameter : Node_Id; |
| -- Name of the parameter which will hold the exception sent by the |
| -- remote subprogram. |
| |
| Current_Parameter : Node_Id; |
| -- Current parameter being handled |
| |
| Ordered_Parameters_List : constant List_Id := |
| Build_Ordered_Parameters_List (Spec); |
| |
| Asynchronous_P : Node_Id; |
| -- A Boolean expression indicating whether this call is asynchronous |
| |
| Asynchronous_Statements : List_Id := No_List; |
| Non_Asynchronous_Statements : List_Id := No_List; |
| -- Statements specifics to the Asynchronous/Non-Asynchronous cases |
| |
| Extra_Formal_Statements : constant List_Id := New_List; |
| -- List of statements for extra formal parameters. It will appear |
| -- after the regular statements for writing out parameters. |
| |
| After_Statements : constant List_Id := New_List; |
| -- Statements to be executed after call returns (to assign IN OUT or |
| -- OUT parameter values). |
| |
| Etyp : Entity_Id; |
| -- The type of the formal parameter being processed |
| |
| Is_Controlling_Formal : Boolean; |
| Is_First_Controlling_Formal : Boolean; |
| First_Controlling_Formal_Seen : Boolean := False; |
| -- Controlling formal parameters of distributed object primitives |
| -- require special handling, and the first such parameter needs even |
| -- more special handling. |
| |
| begin |
| -- ??? document general form of stub subprograms for the PolyORB case |
| |
| Append_To (Decls, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Request, |
| Aliased_Present => True, |
| Object_Definition => |
| New_Occurrence_Of (RTE (RE_Request), Loc))); |
| |
| Result := Make_Temporary (Loc, 'R'); |
| |
| if Is_Function then |
| Result_TC := |
| PolyORB_Support.Helpers.Build_TypeCode_Call |
| (Loc, Etype (Result_Definition (Spec)), Decls); |
| else |
| Result_TC := New_Occurrence_Of (RTE (RE_TC_Void), Loc); |
| end if; |
| |
| Append_To (Decls, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Result, |
| Aliased_Present => False, |
| Object_Definition => |
| New_Occurrence_Of (RTE (RE_NamedValue), Loc), |
| Expression => |
| Make_Aggregate (Loc, |
| Component_Associations => New_List ( |
| Make_Component_Association (Loc, |
| Choices => New_List (Make_Identifier (Loc, Name_Name)), |
| Expression => |
| New_Occurrence_Of (RTE (RE_Result_Name), Loc)), |
| Make_Component_Association (Loc, |
| Choices => New_List ( |
| Make_Identifier (Loc, Name_Argument)), |
| Expression => |
| Make_Function_Call (Loc, |
| Name => New_Occurrence_Of (RTE (RE_Create_Any), Loc), |
| Parameter_Associations => New_List (Result_TC))), |
| Make_Component_Association (Loc, |
| Choices => New_List ( |
| Make_Identifier (Loc, Name_Arg_Modes)), |
| Expression => Make_Integer_Literal (Loc, 0)))))); |
| |
| if not Is_Known_Asynchronous then |
| Exception_Return_Parameter := Make_Temporary (Loc, 'E'); |
| |
| Append_To (Decls, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Exception_Return_Parameter, |
| Object_Definition => |
| New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc))); |
| |
| else |
| Exception_Return_Parameter := Empty; |
| end if; |
| |
| -- Initialize and fill in arguments list |
| |
| Arguments := Make_Temporary (Loc, 'A'); |
| Declare_Create_NVList (Loc, Arguments, Decls, Statements); |
| |
| Current_Parameter := First (Ordered_Parameters_List); |
| while Present (Current_Parameter) loop |
| if Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type) then |
| Is_Controlling_Formal := True; |
| Is_First_Controlling_Formal := |
| not First_Controlling_Formal_Seen; |
| First_Controlling_Formal_Seen := True; |
| |
| else |
| Is_Controlling_Formal := False; |
| Is_First_Controlling_Formal := False; |
| end if; |
| |
| if Is_Controlling_Formal then |
| |
| -- For a controlling formal argument, we send its reference |
| |
| Etyp := RACW_Type; |
| |
| else |
| Etyp := Etype (Parameter_Type (Current_Parameter)); |
| end if; |
| |
| -- The first controlling formal parameter is treated specially: |
| -- it is used to set the target object of the call. |
| |
| if not Is_First_Controlling_Formal then |
| declare |
| Constrained : constant Boolean := |
| Is_Constrained (Etyp) |
| or else Is_Elementary_Type (Etyp); |
| |
| Any : constant Entity_Id := Make_Temporary (Loc, 'A'); |
| |
| Actual_Parameter : Node_Id := |
| New_Occurrence_Of ( |
| Defining_Identifier ( |
| Current_Parameter), Loc); |
| |
| Expr : Node_Id; |
| |
| begin |
| if Is_Controlling_Formal then |
| |
| -- For a controlling formal parameter (other than the |
| -- first one), use the corresponding RACW. If the |
| -- parameter is not an anonymous access parameter, that |
| -- involves taking its 'Unrestricted_Access. |
| |
| if Nkind (Parameter_Type (Current_Parameter)) |
| = N_Access_Definition |
| then |
| Actual_Parameter := OK_Convert_To |
| (Etyp, Actual_Parameter); |
| else |
| Actual_Parameter := OK_Convert_To (Etyp, |
| Make_Attribute_Reference (Loc, |
| Prefix => Actual_Parameter, |
| Attribute_Name => Name_Unrestricted_Access)); |
| end if; |
| |
| end if; |
| |
| if In_Present (Current_Parameter) |
| or else not Out_Present (Current_Parameter) |
| or else not Constrained |
| or else Is_Controlling_Formal |
| then |
| -- The parameter has an input value, is constrained at |
| -- runtime by an input value, or is a controlling formal |
| -- parameter (always passed as a reference) other than |
| -- the first one. |
| |
| Expr := PolyORB_Support.Helpers.Build_To_Any_Call |
| (Loc, Actual_Parameter, Decls); |
| |
| else |
| Expr := Make_Function_Call (Loc, |
| Name => New_Occurrence_Of (RTE (RE_Create_Any), Loc), |
| Parameter_Associations => New_List ( |
| PolyORB_Support.Helpers.Build_TypeCode_Call |
| (Loc, Etyp, Decls))); |
| end if; |
| |
| Append_To (Decls, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Any, |
| Aliased_Present => False, |
| Object_Definition => |
| New_Occurrence_Of (RTE (RE_Any), Loc), |
| Expression => Expr)); |
| |
| Append_To (Statements, |
| Add_Parameter_To_NVList (Loc, |
| Parameter => Current_Parameter, |
| NVList => Arguments, |
| Constrained => Constrained, |
| Any => Any)); |
| |
| if Out_Present (Current_Parameter) |
| and then not Is_Controlling_Formal |
| then |
| if Is_Limited_Type (Etyp) then |
| Helpers.Assign_Opaque_From_Any (Loc, |
| Stms => After_Statements, |
| Typ => Etyp, |
| N => New_Occurrence_Of (Any, Loc), |
| Target => |
| Defining_Identifier (Current_Parameter), |
| Constrained => True); |
| |
| else |
| Append_To (After_Statements, |
| Make_Assignment_Statement (Loc, |
| Name => |
| New_Occurrence_Of ( |
| Defining_Identifier (Current_Parameter), Loc), |
| Expression => |
| PolyORB_Support.Helpers.Build_From_Any_Call |
| (Etyp, |
| New_Occurrence_Of (Any, Loc), |
| Decls))); |
| end if; |
| end if; |
| end; |
| end if; |
| |
| -- If the current parameter has a dynamic constrained status, then |
| -- this status is transmitted as well. |
| |
| -- This should be done for accessibility as well ??? |
| |
| if Nkind (Parameter_Type (Current_Parameter)) /= |
| N_Access_Definition |
| and then Need_Extra_Constrained (Current_Parameter) |
| then |
| -- In this block, we do not use the extra formal that has been |
| -- created because it does not exist at the time of expansion |
| -- when building calling stubs for remote access to subprogram |
| -- types. We create an extra variable of this type and push it |
| -- in the stream after the regular parameters. |
| |
| declare |
| Extra_Any_Parameter : constant Entity_Id := |
| Make_Temporary (Loc, 'P'); |
| |
| Parameter_Exp : constant Node_Id := |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Occurrence_Of ( |
| Defining_Identifier (Current_Parameter), Loc), |
| Attribute_Name => Name_Constrained); |
| |
| begin |
| Set_Etype (Parameter_Exp, Etype (Standard_Boolean)); |
| |
| Append_To (Decls, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Extra_Any_Parameter, |
| Aliased_Present => False, |
| Object_Definition => |
| New_Occurrence_Of (RTE (RE_Any), Loc), |
| Expression => |
| PolyORB_Support.Helpers.Build_To_Any_Call |
| (Loc, Parameter_Exp, Decls))); |
| |
| Append_To (Extra_Formal_Statements, |
| Add_Parameter_To_NVList (Loc, |
| Parameter => Extra_Any_Parameter, |
| NVList => Arguments, |
| Constrained => True, |
| Any => Extra_Any_Parameter)); |
| end; |
| end if; |
| |
| Next (Current_Parameter); |
| end loop; |
| |
| -- Append the formal statements list to the statements |
| |
| Append_List_To (Statements, Extra_Formal_Statements); |
| |
| Append_To (Statements, |
| Make_Procedure_Call_Statement (Loc, |
| Name => |
| New_Occurrence_Of (RTE (RE_Request_Setup), Loc), |
| Parameter_Associations => New_List ( |
| New_Occurrence_Of (Request, Loc), |
| Target_Object, |
| Subprogram_Id, |
| New_Occurrence_Of (Arguments, Loc), |
| New_Occurrence_Of (Result, Loc), |
| New_Occurrence_Of (RTE (RE_Nil_Exc_List), Loc)))); |
| |
| pragma Assert |
| (not (Is_Known_Non_Asynchronous and Is_Known_Asynchronous)); |
| |
| if Is_Known_Non_Asynchronous or Is_Known_Asynchronous then |
| Asynchronous_P := |
| New_Occurrence_Of |
| (Boolean_Literals (Is_Known_Asynchronous), Loc); |
| |
| else |
| pragma Assert (Present (Asynchronous)); |
| Asynchronous_P := New_Copy_Tree (Asynchronous); |
| |
| -- The expression node Asynchronous will be used to build an 'if' |
| -- statement at the end of Build_General_Calling_Stubs: we need to |
| -- make a copy here. |
| end if; |
| |
| Append_To (Parameter_Associations (Last (Statements)), |
| Make_Indexed_Component (Loc, |
| Prefix => |
| New_Occurrence_Of ( |
| RTE (RE_Asynchronous_P_To_Sync_Scope), Loc), |
| Expressions => New_List (Asynchronous_P))); |
| |
| Append_To (Statements, Make_Request_RTE_Call (RE_Request_Invoke)); |
| |
| -- Asynchronous case |
| |
| if not Is_Known_Non_Asynchronous then |
| Asynchronous_Statements := New_List (Make_Null_Statement (Loc)); |
| end if; |
| |
| -- Non-asynchronous case |
| |
| if not Is_Known_Asynchronous then |
| -- Reraise an exception occurrence from the completed request. |
| -- If the exception occurrence is empty, this is a no-op. |
| |
| Non_Asynchronous_Statements := New_List ( |
| Make_Procedure_Call_Statement (Loc, |
| Name => |
| New_Occurrence_Of (RTE (RE_Request_Raise_Occurrence), Loc), |
| Parameter_Associations => New_List ( |
| New_Occurrence_Of (Request, Loc)))); |
| |
| if Is_Function then |
| -- If this is a function call, read the value and return it |
| |
| Append_To (Non_Asynchronous_Statements, |
| Make_Tag_Check (Loc, |
| Make_Simple_Return_Statement (Loc, |
| PolyORB_Support.Helpers.Build_From_Any_Call |
| (Etype (Result_Definition (Spec)), |
| Make_Selected_Component (Loc, |
| Prefix => Result, |
| Selector_Name => Name_Argument), |
| Decls)))); |
| |
| else |
| |
| -- Case of a procedure: deal with IN OUT and OUT formals |
| |
| Append_List_To (Non_Asynchronous_Statements, After_Statements); |
| end if; |
| end if; |
| |
| if Is_Known_Asynchronous then |
| Append_List_To (Statements, Asynchronous_Statements); |
| |
| elsif Is_Known_Non_Asynchronous then |
| Append_List_To (Statements, Non_Asynchronous_Statements); |
| |
| else |
| pragma Assert (Present (Asynchronous)); |
| Append_To (Statements, |
| Make_Implicit_If_Statement (Nod, |
| Condition => Asynchronous, |
| Then_Statements => Asynchronous_Statements, |
| Else_Statements => Non_Asynchronous_Statements)); |
| end if; |
| end Build_General_Calling_Stubs; |
| |
| ----------------------- |
| -- Build_Stub_Target -- |
| ----------------------- |
| |
| function Build_Stub_Target |
| (Loc : Source_Ptr; |
| Decls : List_Id; |
| RCI_Locator : Entity_Id; |
| Controlling_Parameter : Entity_Id) return RPC_Target |
| is |
| Target_Info : RPC_Target (PCS_Kind => Name_PolyORB_DSA); |
| Target_Reference : constant Entity_Id := Make_Temporary (Loc, 'T'); |
| |
| begin |
| if Present (Controlling_Parameter) then |
| Append_To (Decls, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Target_Reference, |
| |
| Object_Definition => |
| New_Occurrence_Of (RTE (RE_Object_Ref), Loc), |
| |
| Expression => |
| Make_Function_Call (Loc, |
| Name => |
| New_Occurrence_Of (RTE (RE_Make_Ref), Loc), |
| Parameter_Associations => New_List ( |
| Make_Selected_Component (Loc, |
| Prefix => Controlling_Parameter, |
| Selector_Name => Name_Target))))); |
| |
| -- Note: Controlling_Parameter has the same components as |
| -- System.Partition_Interface.RACW_Stub_Type. |
| |
| Target_Info.Object := New_Occurrence_Of (Target_Reference, Loc); |
| |
| else |
| Target_Info.Object := |
| Make_Selected_Component (Loc, |
| Prefix => |
| Make_Identifier (Loc, Chars (RCI_Locator)), |
| Selector_Name => |
| Make_Identifier (Loc, Name_Get_RCI_Package_Ref)); |
| end if; |
| |
| return Target_Info; |
| end Build_Stub_Target; |
| |
| ----------------------------- |
| -- Build_RPC_Receiver_Body -- |
| ----------------------------- |
| |
| procedure Build_RPC_Receiver_Body |
| (RPC_Receiver : Entity_Id; |
| Request : out Entity_Id; |
| Subp_Id : out Entity_Id; |
| Subp_Index : out Entity_Id; |
| Stmts : out List_Id; |
| Decl : out Node_Id) |
| is |
| Loc : constant Source_Ptr := Sloc (RPC_Receiver); |
| |
| RPC_Receiver_Spec : Node_Id; |
| RPC_Receiver_Decls : List_Id; |
| |
| begin |
| Request := Make_Defining_Identifier (Loc, Name_R); |
| |
| RPC_Receiver_Spec := |
| Build_RPC_Receiver_Specification |
| (RPC_Receiver => RPC_Receiver, |
| Request_Parameter => Request); |
| |
| Subp_Id := Make_Defining_Identifier (Loc, Name_P); |
| Subp_Index := Make_Defining_Identifier (Loc, Name_I); |
| |
| RPC_Receiver_Decls := New_List ( |
| Make_Object_Renaming_Declaration (Loc, |
| Defining_Identifier => Subp_Id, |
| Subtype_Mark => New_Occurrence_Of (Standard_String, Loc), |
| Name => |
| Make_Explicit_Dereference (Loc, |
| Prefix => |
| Make_Selected_Component (Loc, |
| Prefix => Request, |
| Selector_Name => Name_Operation))), |
| |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Subp_Index, |
| Object_Definition => |
| New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc), |
| Expression => |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc), |
| Attribute_Name => Name_Last))); |
| |
| Stmts := New_List; |
| |
| Decl := |
| Make_Subprogram_Body (Loc, |
| Specification => RPC_Receiver_Spec, |
| Declarations => RPC_Receiver_Decls, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => Stmts)); |
| end Build_RPC_Receiver_Body; |
| |
| -------------------------------------- |
| -- Build_Subprogram_Receiving_Stubs -- |
| -------------------------------------- |
| |
| function Build_Subprogram_Receiving_Stubs |
| (Vis_Decl : Node_Id; |
| Asynchronous : Boolean; |
| Dynamically_Asynchronous : Boolean := False; |
| Stub_Type : Entity_Id := Empty; |
| RACW_Type : Entity_Id := Empty; |
| Parent_Primitive : Entity_Id := Empty) return Node_Id |
| is |
| Loc : constant Source_Ptr := Sloc (Vis_Decl); |
| |
| Request_Parameter : constant Entity_Id := Make_Temporary (Loc, 'R'); |
| -- Formal parameter for receiving stubs: a descriptor for an incoming |
| -- request. |
| |
| Outer_Decls : constant List_Id := New_List; |
| -- At the outermost level, an NVList and Any's are declared for all |
| -- parameters. The Dynamic_Async flag also needs to be declared there |
| -- to be visible from the exception handling code. |
| |
| Outer_Statements : constant List_Id := New_List; |
| -- Statements that occur prior to the declaration of the actual |
| -- parameter variables. |
| |
| Outer_Extra_Formal_Statements : constant List_Id := New_List; |
| -- Statements concerning extra formal parameters, prior to the |
| -- declaration of the actual parameter variables. |
| |
| Decls : constant List_Id := New_List; |
| -- All the parameters will get declared before calling the real |
| -- subprograms. Also the out parameters will be declared. At this |
| -- level, parameters may be unconstrained. |
| |
| Statements : constant List_Id := New_List; |
| |
| After_Statements : constant List_Id := New_List; |
| -- Statements to be executed after the subprogram call |
| |
| Inner_Decls : List_Id := No_List; |
| -- In case of a function, the inner declarations are needed since |
| -- the result may be unconstrained. |
| |
| Excep_Handlers : List_Id := No_List; |
| |
| Parameter_List : constant List_Id := New_List; |
| -- List of parameters to be passed to the subprogram |
| |
| First_Controlling_Formal_Seen : Boolean := False; |
| |
| Current_Parameter : Node_Id; |
| |
| Ordered_Parameters_List : constant List_Id := |
| Build_Ordered_Parameters_List |
| (Specification (Vis_Decl)); |
| |
| Arguments : constant Entity_Id := Make_Temporary (Loc, 'A'); |
| -- Name of the named values list used to retrieve parameters |
| |
| Subp_Spec : Node_Id; |
| -- Subprogram specification |
| |
| Called_Subprogram : Node_Id; |
| -- The subprogram to call |
| |
| begin |
| if Present (RACW_Type) then |
| Called_Subprogram := |
| New_Occurrence_Of (Parent_Primitive, Loc); |
| else |
| Called_Subprogram := |
| New_Occurrence_Of |
| (Defining_Unit_Name (Specification (Vis_Decl)), Loc); |
| end if; |
| |
| Declare_Create_NVList (Loc, Arguments, Outer_Decls, Outer_Statements); |
| |
| -- Loop through every parameter and get its value from the stream. If |
| -- the parameter is unconstrained, then the parameter is read using |
| -- 'Input at the point of declaration. |
| |
| Current_Parameter := First (Ordered_Parameters_List); |
| while Present (Current_Parameter) loop |
| declare |
| Etyp : Entity_Id; |
| Constrained : Boolean; |
| Any : Entity_Id := Empty; |
| Object : constant Entity_Id := Make_Temporary (Loc, 'P'); |
| Expr : Node_Id := Empty; |
| |
| Is_Controlling_Formal : constant Boolean := |
| Is_RACW_Controlling_Formal |
| (Current_Parameter, Stub_Type); |
| |
| Is_First_Controlling_Formal : Boolean := False; |
| |
| Need_Extra_Constrained : Boolean; |
| -- True when an extra constrained actual is required |
| |
| begin |
| if Is_Controlling_Formal then |
| |
| -- Controlling formals in distributed object primitive |
| -- operations are handled specially: |
| |
| -- - the first controlling formal is used as the |
| -- target of the call; |
| |
| -- - the remaining controlling formals are transmitted |
| -- as RACWs. |
| |
| Etyp := RACW_Type; |
| Is_First_Controlling_Formal := |
| not First_Controlling_Formal_Seen; |
| First_Controlling_Formal_Seen := True; |
| |
| else |
| Etyp := Etype (Parameter_Type (Current_Parameter)); |
| end if; |
| |
| Constrained := |
| Is_Constrained (Etyp) or else Is_Elementary_Type (Etyp); |
| |
| if not Is_First_Controlling_Formal then |
| Any := Make_Temporary (Loc, 'A'); |
| |
| Append_To (Outer_Decls, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Any, |
| Object_Definition => |
| New_Occurrence_Of (RTE (RE_Any), Loc), |
| Expression => |
| Make_Function_Call (Loc, |
| Name => New_Occurrence_Of (RTE (RE_Create_Any), Loc), |
| Parameter_Associations => New_List ( |
| PolyORB_Support.Helpers.Build_TypeCode_Call |
| (Loc, Etyp, Outer_Decls))))); |
| |
| Append_To (Outer_Statements, |
| Add_Parameter_To_NVList (Loc, |
| Parameter => Current_Parameter, |
| NVList => Arguments, |
| Constrained => Constrained, |
| Any => Any)); |
| end if; |
| |
| if Is_First_Controlling_Formal then |
| declare |
| Addr : constant Entity_Id := Make_Temporary (Loc, 'A'); |
| |
| Is_Local : constant Entity_Id := |
| Make_Temporary (Loc, 'L'); |
| |
| begin |
| -- Special case: obtain the first controlling formal |
| -- from the target of the remote call, instead of the |
| -- argument list. |
| |
| Append_To (Outer_Decls, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Addr, |
| Object_Definition => |
| New_Occurrence_Of (RTE (RE_Address), Loc))); |
| |
| Append_To (Outer_Decls, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Is_Local, |
| Object_Definition => |
| New_Occurrence_Of (Standard_Boolean, Loc))); |
| |
| Append_To (Outer_Statements, |
| Make_Procedure_Call_Statement (Loc, |
| Name => |
| New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc), |
| Parameter_Associations => New_List ( |
| Make_Selected_Component (Loc, |
| Prefix => |
| New_Occurrence_Of ( |
| Request_Parameter, Loc), |
| Selector_Name => |
| Make_Identifier (Loc, Name_Target)), |
| New_Occurrence_Of (Is_Local, Loc), |
| New_Occurrence_Of (Addr, Loc)))); |
| |
| Expr := Unchecked_Convert_To (RACW_Type, |
| New_Occurrence_Of (Addr, Loc)); |
| end; |
| |
| elsif In_Present (Current_Parameter) |
| or else not Out_Present (Current_Parameter) |
| or else not Constrained |
| then |
| -- If an input parameter is constrained, then its reading is |
| -- deferred until the beginning of the subprogram body. If |
| -- it is unconstrained, then an expression is built for |
| -- the object declaration and the variable is set using |
| -- 'Input instead of 'Read. |
| |
| if Constrained and then Is_Limited_Type (Etyp) then |
| Helpers.Assign_Opaque_From_Any (Loc, |
| Stms => Statements, |
| Typ => Etyp, |
| N => New_Occurrence_Of (Any, Loc), |
| Target => Object); |
| |
| else |
| Expr := Helpers.Build_From_Any_Call |
| (Etyp, New_Occurrence_Of (Any, Loc), Decls); |
| |
| if Constrained then |
| Append_To (Statements, |
| Make_Assignment_Statement (Loc, |
| Name => New_Occurrence_Of (Object, Loc), |
| Expression => Expr)); |
| Expr := Empty; |
| |
| else |
| -- Expr will be used to initialize (and constrain) the |
| -- parameter when it is declared. |
| null; |
| end if; |
| |
| null; |
| end if; |
| end if; |
| |
| Need_Extra_Constrained := |
| Nkind (Parameter_Type (Current_Parameter)) /= |
| N_Access_Definition |
| and then |
| Ekind (Defining_Identifier (Current_Parameter)) /= E_Void |
| and then |
| Present (Extra_Constrained |
| (Defining_Identifier (Current_Parameter))); |
| |
| -- We may not associate an extra constrained actual to a |
| -- constant object, so if one is needed, declare the actual |
| -- as a variable even if it won't be modified. |
| |
| Build_Actual_Object_Declaration |
| (Object => Object, |
| Etyp => Etyp, |
| Variable => Need_Extra_Constrained |
| or else Out_Present (Current_Parameter), |
| Expr => Expr, |
| Decls => Decls); |
| Set_Etype (Object, Etyp); |
| |
| -- An out parameter may be written back using a 'Write |
| -- attribute instead of a 'Output because it has been |
| -- constrained by the parameter given to the caller. Note that |
| -- OUT controlling arguments in the case of a RACW are not put |
| -- back in the stream because the pointer on them has not |
| -- changed. |
| |
| if Out_Present (Current_Parameter) |
| and then not Is_Controlling_Formal |
| then |
| Append_To (After_Statements, |
| Make_Procedure_Call_Statement (Loc, |
| Name => New_Occurrence_Of (RTE (RE_Move_Any_Value), Loc), |
| Parameter_Associations => New_List ( |
| New_Occurrence_Of (Any, Loc), |
| PolyORB_Support.Helpers.Build_To_Any_Call |
| (Loc, |
| New_Occurrence_Of (Object, Loc), |
| Decls, |
| Constrained => True)))); |
| end if; |
| |
| -- For RACW controlling formals, the Etyp of Object is always |
| -- an RACW, even if the parameter is not of an anonymous access |
| -- type. In such case, we need to dereference it at call time. |
| |
| if Is_Controlling_Formal then |
| if Nkind (Parameter_Type (Current_Parameter)) /= |
| N_Access_Definition |
| then |
| Append_To (Parameter_List, |
| Make_Parameter_Association (Loc, |
| Selector_Name => |
| New_Occurrence_Of |
| (Defining_Identifier (Current_Parameter), Loc), |
| Explicit_Actual_Parameter => |
| Make_Explicit_Dereference (Loc, |
| Prefix => New_Occurrence_Of (Object, Loc)))); |
| |
| else |
| Append_To (Parameter_List, |
| Make_Parameter_Association (Loc, |
| Selector_Name => |
| New_Occurrence_Of |
| (Defining_Identifier (Current_Parameter), Loc), |
| |
| Explicit_Actual_Parameter => |
| New_Occurrence_Of (Object, Loc))); |
| end if; |
| |
| else |
| Append_To (Parameter_List, |
| Make_Parameter_Association (Loc, |
| Selector_Name => |
| New_Occurrence_Of ( |
| Defining_Identifier (Current_Parameter), Loc), |
| Explicit_Actual_Parameter => |
| New_Occurrence_Of (Object, Loc))); |
| end if; |
| |
| -- If the current parameter needs an extra formal, then read it |
| -- from the stream and set the corresponding semantic field in |
| -- the variable. If the kind of the parameter identifier is |
| -- E_Void, then this is a compiler generated parameter that |
| -- doesn't need an extra constrained status. |
| |
| -- The case of Extra_Accessibility should also be handled ??? |
| |
| if Need_Extra_Constrained then |
| declare |
| Extra_Parameter : constant Entity_Id := |
| Extra_Constrained |
| (Defining_Identifier |
| (Current_Parameter)); |
| |
| Extra_Any : constant Entity_Id := |
| Make_Temporary (Loc, 'A'); |
| |
| Formal_Entity : constant Entity_Id := |
| Make_Defining_Identifier (Loc, |
| Chars => Chars (Extra_Parameter)); |
| |
| Formal_Type : constant Entity_Id := |
| Etype (Extra_Parameter); |
| |
| begin |
| Append_To (Outer_Decls, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Extra_Any, |
| Object_Definition => |
| New_Occurrence_Of (RTE (RE_Any), Loc), |
| Expression => |
| Make_Function_Call (Loc, |
| Name => |
| New_Occurrence_Of (RTE (RE_Create_Any), Loc), |
| Parameter_Associations => New_List ( |
| PolyORB_Support.Helpers.Build_TypeCode_Call |
| (Loc, Formal_Type, Outer_Decls))))); |
| |
| Append_To (Outer_Extra_Formal_Statements, |
| Add_Parameter_To_NVList (Loc, |
| Parameter => Extra_Parameter, |
| NVList => Arguments, |
| Constrained => True, |
| Any => Extra_Any)); |
| |
| Append_To (Decls, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Formal_Entity, |
| Object_Definition => |
| New_Occurrence_Of (Formal_Type, Loc))); |
| |
| Append_To (Statements, |
| Make_Assignment_Statement (Loc, |
| Name => New_Occurrence_Of (Formal_Entity, Loc), |
| Expression => |
| PolyORB_Support.Helpers.Build_From_Any_Call |
| (Formal_Type, |
| New_Occurrence_Of (Extra_Any, Loc), |
| Decls))); |
| Set_Extra_Constrained (Object, Formal_Entity); |
| end; |
| end if; |
| end; |
| |
| Next (Current_Parameter); |
| end loop; |
| |
| -- Extra Formals should go after all the other parameters |
| |
| Append_List_To (Outer_Statements, Outer_Extra_Formal_Statements); |
| |
| Append_To (Outer_Statements, |
| Make_Procedure_Call_Statement (Loc, |
| Name => New_Occurrence_Of (RTE (RE_Request_Arguments), Loc), |
| Parameter_Associations => New_List ( |
| New_Occurrence_Of (Request_Parameter, Loc), |
| New_Occurrence_Of (Arguments, Loc)))); |
| |
| if Nkind (Specification (Vis_Decl)) = N_Function_Specification then |
| |
| -- The remote subprogram is a function: Build an inner block to be |
| -- able to hold a potentially unconstrained result in a variable. |
| |
| declare |
| Etyp : constant Entity_Id := |
| Etype (Result_Definition (Specification (Vis_Decl))); |
| Result : constant Node_Id := Make_Temporary (Loc, 'R'); |
| |
| begin |
| Inner_Decls := New_List ( |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Result, |
| Constant_Present => True, |
| Object_Definition => New_Occurrence_Of (Etyp, Loc), |
| Expression => |
| Make_Function_Call (Loc, |
| Name => Called_Subprogram, |
| Parameter_Associations => Parameter_List))); |
| |
| if Is_Class_Wide_Type (Etyp) then |
| |
| -- For a remote call to a function with a class-wide type, |
| -- check that the returned value satisfies the requirements |
| -- of (RM E.4(18)). |
| |
| Append_To (Inner_Decls, |
| Make_Transportable_Check (Loc, |
| New_Occurrence_Of (Result, Loc))); |
| |
| end if; |
| |
| Set_Etype (Result, Etyp); |
| Append_To (After_Statements, |
| Make_Procedure_Call_Statement (Loc, |
| Name => New_Occurrence_Of (RTE (RE_Set_Result), Loc), |
| Parameter_Associations => New_List ( |
| New_Occurrence_Of (Request_Parameter, Loc), |
| PolyORB_Support.Helpers.Build_To_Any_Call |
| (Loc, New_Occurrence_Of (Result, Loc), Decls)))); |
| |
| -- A DSA function does not have out or inout arguments |
| end; |
| |
| Append_To (Statements, |
| Make_Block_Statement (Loc, |
| Declarations => Inner_Decls, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => After_Statements))); |
| |
| else |
| -- The remote subprogram is a procedure. We do not need any inner |
| -- block in this case. No specific processing is required here for |
| -- the dynamically asynchronous case: the indication of whether |
| -- call is asynchronous or not is managed by the Sync_Scope |
| -- attibute of the request, and is handled entirely in the |
| -- protocol layer. |
| |
| Append_To (After_Statements, |
| Make_Procedure_Call_Statement (Loc, |
| Name => New_Occurrence_Of (RTE (RE_Request_Set_Out), Loc), |
| Parameter_Associations => New_List ( |
| New_Occurrence_Of (Request_Parameter, Loc)))); |
| |
| Append_To (Statements, |
| Make_Procedure_Call_Statement (Loc, |
| Name => Called_Subprogram, |
| Parameter_Associations => Parameter_List)); |
| |
| Append_List_To (Statements, After_Statements); |
| end if; |
| |
| Subp_Spec := |
| Make_Procedure_Specification (Loc, |
| Defining_Unit_Name => Make_Temporary (Loc, 'F'), |
| |
| Parameter_Specifications => New_List ( |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => Request_Parameter, |
| Parameter_Type => |
| New_Occurrence_Of (RTE (RE_Request_Access), Loc)))); |
| |
| -- An exception raised during the execution of an incoming remote |
| -- subprogram call and that needs to be sent back to the caller is |
| -- propagated by the receiving stubs, and will be handled by the |
| -- caller (the distribution runtime). |
| |
| if Asynchronous and then not Dynamically_Asynchronous then |
| |
| -- For an asynchronous procedure, add a null exception handler |
| |
| Excep_Handlers := New_List ( |
| Make_Implicit_Exception_Handler (Loc, |
| Exception_Choices => New_List (Make_Others_Choice (Loc)), |
| Statements => New_List (Make_Null_Statement (Loc)))); |
| |
| else |
| -- In the other cases, if an exception is raised, then the |
| -- exception occurrence is propagated. |
| |
| null; |
| end if; |
| |
| Append_To (Outer_Statements, |
| Make_Block_Statement (Loc, |
| Declarations => Decls, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => Statements))); |
| |
| return |
| Make_Subprogram_Body (Loc, |
| Specification => Subp_Spec, |
| Declarations => Outer_Decls, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => Outer_Statements, |
| Exception_Handlers => Excep_Handlers)); |
| end Build_Subprogram_Receiving_Stubs; |
| |
| ------------- |
| -- Helpers -- |
| ------------- |
| |
| package body Helpers is |
| |
| ----------------------- |
| -- Local Subprograms -- |
| ----------------------- |
| |
| function Find_Numeric_Representation |
| (Typ : Entity_Id) return Entity_Id; |
| -- Given a numeric type Typ, return the smallest integer or modular |
| -- type from Interfaces, or the smallest floating point type from |
| -- Standard whose range encompasses that of Typ. |
| |
| function Is_Generic_Actual_Subtype (Typ : Entity_Id) return Boolean; |
| -- Return true if Typ is a subtype representing a generic formal type |
| -- as a subtype of the actual type in an instance. This is needed to |
| -- recognize these subtypes because the Is_Generic_Actual_Type flag |
| -- can only be relied upon within the instance. |
| |
| function Make_Helper_Function_Name |
| (Loc : Source_Ptr; |
| Typ : Entity_Id; |
| Nam : Name_Id) return Entity_Id; |
| -- Return the name to be assigned for helper subprogram Nam of Typ |
| |
| ------------------------------------------------------------ |
| -- Common subprograms for building various tree fragments -- |
| ------------------------------------------------------------ |
| |
| function Build_Get_Aggregate_Element |
| (Loc : Source_Ptr; |
| Any : Entity_Id; |
| TC : Node_Id; |
| Idx : Node_Id) return Node_Id; |
| -- Build a call to Get_Aggregate_Element on Any for typecode TC, |
| -- returning the Idx'th element. |
| |
| generic |
| Subprogram : Entity_Id; |
| -- Reference location for constructed nodes |
| |
| Arry : Entity_Id; |
| -- For 'Range and Etype |
| |
| Indexes : List_Id; |
| -- For the construction of the innermost element expression |
| |
| with procedure Add_Process_Element |
| (Stmts : List_Id; |
| Any : Entity_Id; |
| Counter : Entity_Id; |
| Datum : Node_Id); |
| |
| procedure Append_Array_Traversal |
| (Stmts : List_Id; |
| Any : Entity_Id; |
| Counter : Entity_Id := Empty; |
| Depth : Pos := 1); |
| -- Build nested loop statements that iterate over the elements of an |
| -- array Arry. The statement(s) built by Add_Process_Element are |
| -- executed for each element; Indexes is the list of indexes to be |
| -- used in the construction of the indexed component that denotes the |
| -- current element. Subprogram is the entity for the subprogram for |
| -- which this iterator is generated. The generated statements are |
| -- appended to Stmts. |
| |
| generic |
| Rec : Entity_Id; |
| -- The record entity being dealt with |
| |
| with procedure Add_Process_Element |
| (Stmts : List_Id; |
| Container : Node_Or_Entity_Id; |
| Counter : in out Nat; |
| Rec : Entity_Id; |
| Field : Node_Id); |
| -- Rec is the instance of the record type, or Empty. |
| -- Field is either the N_Defining_Identifier for a component, |
| -- or an N_Variant_Part. |
| |
| procedure Append_Record_Traversal |
| (Stmts : List_Id; |
| Clist : Node_Id; |
| Container : Node_Or_Entity_Id; |
| Counter : in out Nat); |
| -- Process component list Clist. Individual fields are passed |
| -- to Field_Processing. Each variant part is also processed. |
| -- Container is the outer Any (for From_Any/To_Any), |
| -- the outer typecode (for TC) to which the operation applies. |
| |
| ----------------------------- |
| -- Append_Record_Traversal -- |
| ----------------------------- |
| |
| procedure Append_Record_Traversal |
| (Stmts : List_Id; |
| Clist : Node_Id; |
| Container : Node_Or_Entity_Id; |
| Counter : in out Nat) |
| is |
| CI : List_Id; |
| VP : Node_Id; |
| -- Clist's Component_Items and Variant_Part |
| |
| Item : Node_Id; |
| Def : Entity_Id; |
| |
| begin |
| if No (Clist) then |
| return; |
| end if; |
| |
| CI := Component_Items (Clist); |
| VP := Variant_Part (Clist); |
| |
| Item := First (CI); |
| while Present (Item) loop |
| Def := Defining_Identifier (Item); |
| |
| if not Is_Internal_Name (Chars (Def)) then |
| Add_Process_Element |
| (Stmts, Container, Counter, Rec, Def); |
| end if; |
| |
| Next (Item); |
| end loop; |
| |
| if Present (VP) then |
| Add_Process_Element (Stmts, Container, Counter, Rec, VP); |
| end if; |
| end Append_Record_Traversal; |
| |
| ----------------------------- |
| -- Assign_Opaque_From_Any -- |
| ----------------------------- |
| |
| procedure Assign_Opaque_From_Any |
| (Loc : Source_Ptr; |
| Stms : List_Id; |
| Typ : Entity_Id; |
| N : Node_Id; |
| Target : Entity_Id; |
| Constrained : Boolean := False) |
| is |
| Strm : constant Entity_Id := Make_Temporary (Loc, 'S'); |
| Expr : Node_Id; |
| |
| Read_Call_List : List_Id; |
| -- List on which to place the 'Read attribute reference |
| |
| begin |
| -- Strm : Buffer_Stream_Type; |
| |
| Append_To (Stms, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Strm, |
| Aliased_Present => True, |
| Object_Definition => |
| New_Occurrence_Of (RTE (RE_Buffer_Stream_Type), Loc))); |
| |
| -- Any_To_BS (Strm, A); |
| |
| Append_To (Stms, |
| Make_Procedure_Call_Statement (Loc, |
| Name => New_Occurrence_Of (RTE (RE_Any_To_BS), Loc), |
| Parameter_Associations => New_List ( |
| N, |
| New_Occurrence_Of (Strm, Loc)))); |
| |
| if Transmit_As_Unconstrained (Typ) and then not Constrained then |
| Expr := |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Occurrence_Of (Typ, Loc), |
| Attribute_Name => Name_Input, |
| Expressions => New_List ( |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Occurrence_Of (Strm, Loc), |
| Attribute_Name => Name_Access))); |
| |
| -- Target := Typ'Input (Strm'Access) |
| |
| if Present (Target) then |
| Append_To (Stms, |
| Make_Assignment_Statement (Loc, |
| Name => New_Occurrence_Of (Target, Loc), |
| Expression => Expr)); |
| |
| -- return Typ'Input (Strm'Access); |
| |
| else |
| Append_To (Stms, |
| Make_Simple_Return_Statement (Loc, |
| Expression => Expr)); |
| end if; |
| |
| else |
| if Present (Target) then |
| Read_Call_List := Stms; |
| Expr := New_Occurrence_Of (Target, Loc); |
| |
| else |
| declare |
| Temp : constant Entity_Id := Make_Temporary (Loc, 'R'); |
| |
| begin |
| Read_Call_List := New_List; |
| Expr := New_Occurrence_Of (Temp, Loc); |
| |
| Append_To (Stms, Make_Block_Statement (Loc, |
| Declarations => New_List ( |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => |
| Temp, |
| Object_Definition => |
| New_Occurrence_Of (Typ, Loc))), |
| |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => Read_Call_List))); |
| end; |
| end if; |
| |
| -- Typ'Read (Strm'Access, [Target|Temp]) |
| |
| Append_To (Read_Call_List, |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Occurrence_Of (Typ, Loc), |
| Attribute_Name => Name_Read, |
| Expressions => New_List ( |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Occurrence_Of (Strm, Loc), |
| Attribute_Name => Name_Access), |
| Expr))); |
| |
| if No (Target) then |
| |
| -- return Temp |
| |
| Append_To (Read_Call_List, |
| Make_Simple_Return_Statement (Loc, |
| Expression => New_Copy (Expr))); |
| end if; |
| end if; |
| end Assign_Opaque_From_Any; |
| |
| ------------------------- |
| -- Build_From_Any_Call -- |
| ------------------------- |
| |
| function Build_From_Any_Call |
| (Typ : Entity_Id; |
| N : Node_Id; |
| Decls : List_Id) return Node_Id |
| is |
| Loc : constant Source_Ptr := Sloc (N); |
| |
| U_Type : Entity_Id := Underlying_Type (Typ); |
| |
| Fnam : Entity_Id; |
| Lib_RE : RE_Id := RE_Null; |
| Result : Node_Id; |
| |
| begin |
| -- First simple case where the From_Any function is present |
| -- in the type's TSS. |
| |
| Fnam := Find_Inherited_TSS (U_Type, TSS_From_Any); |
| |
| -- For the subtype representing a generic actual type, go to the |
| -- actual type. |
| |
| if Is_Generic_Actual_Subtype (U_Type) then |
| U_Type := Underlying_Type (Base_Type (U_Type)); |
| end if; |
| |
| -- For a standard subtype, go to the base type |
| |
| if Sloc (U_Type) <= Standard_Location then |
| U_Type := Base_Type (U_Type); |
| |
| -- For a user subtype, go to first subtype |
| |
| elsif Comes_From_Source (U_Type) |
| and then Nkind (Declaration_Node (U_Type)) |
| = N_Subtype_Declaration |
| then |
| U_Type := First_Subtype (U_Type); |
| end if; |
| |
| -- Check first for Boolean and Character. These are enumeration |
| -- types, but we treat them specially, since they may require |
| -- special handling in the transfer protocol. However, this |
| -- special handling only applies if they have standard |
| -- representation, otherwise they are treated like any other |
| -- enumeration type. |
| |
| if Present (Fnam) then |
| null; |
| |
| elsif U_Type = Standard_Boolean then |
| Lib_RE := RE_FA_B; |
| |
| elsif U_Type = Standard_Character then |
| Lib_RE := RE_FA_C; |
| |
| elsif U_Type = Standard_Wide_Character then |
| Lib_RE := RE_FA_WC; |
| |
| elsif U_Type = Standard_Wide_Wide_Character then |
| Lib_RE := RE_FA_WWC; |
| |
| -- Floating point types |
| |
| elsif U_Type = Standard_Short_Float then |
| Lib_RE := RE_FA_SF; |
| |
| elsif U_Type = Standard_Float then |
| Lib_RE := RE_FA_F; |
| |
| elsif U_Type = Standard_Long_Float then |
| Lib_RE := RE_FA_LF; |
| |
| elsif U_Type = Standard_Long_Long_Float then |
| Lib_RE := RE_FA_LLF; |
| |
| -- Integer types |
| |
| elsif U_Type = RTE (RE_Integer_8) then |
| Lib_RE := RE_FA_I8; |
| |
| elsif U_Type = RTE (RE_Integer_16) then |
| Lib_RE := RE_FA_I16; |
| |
| elsif U_Type = RTE (RE_Integer_32) then |
| Lib_RE := RE_FA_I32; |
| |
| elsif U_Type = RTE (RE_Integer_64) then |
| Lib_RE := RE_FA_I64; |
| |
| -- Unsigned integer types |
| |
| elsif U_Type = RTE (RE_Unsigned_8) then |
| Lib_RE := RE_FA_U8; |
| |
| elsif U_Type = RTE (RE_Unsigned_16) then |
| Lib_RE := RE_FA_U16; |
| |
| elsif U_Type = RTE (RE_Unsigned_32) then |
| Lib_RE := RE_FA_U32; |
| |
| elsif U_Type = RTE (RE_Unsigned_64) then |
| Lib_RE := RE_FA_U64; |
| |
| elsif Is_RTE (U_Type, RE_Unbounded_String) then |
| Lib_RE := RE_FA_String; |
| |
| -- Special DSA types |
| |
| elsif Is_RTE (U_Type, RE_Any_Container_Ptr) then |
| Lib_RE := RE_FA_A; |
| |
| -- Other (non-primitive) types |
| |
| else |
| declare |
| Decl : Entity_Id; |
| |
| begin |
| Build_From_Any_Function (Loc, U_Type, Decl, Fnam); |
| Append_To (Decls, Decl); |
| end; |
| end if; |
| |
| -- Call the function |
| |
| if Lib_RE /= RE_Null then |
| pragma Assert (No (Fnam)); |
| Fnam := RTE (Lib_RE); |
| end if; |
| |
| Result := |
| Make_Function_Call (Loc, |
| Name => New_Occurrence_Of (Fnam, Loc), |
| Parameter_Associations => New_List (N)); |
| |
| -- We must set the type of Result, so the unchecked conversion |
| -- from the underlying type to the base type is properly done. |
| |
| Set_Etype (Result, U_Type); |
| |
| return Unchecked_Convert_To (Typ, Result); |
| end Build_From_Any_Call; |
| |
| ----------------------------- |
| -- Build_From_Any_Function -- |
| ----------------------------- |
| |
| procedure Build_From_Any_Function |
| (Loc : Source_Ptr; |
| Typ : Entity_Id; |
| Decl : out Node_Id; |
| Fnam : out Entity_Id) |
| is |
| Spec : Node_Id; |
| Decls : constant List_Id := New_List; |
| Stms : constant List_Id := New_List; |
| |
| Any_Parameter : constant Entity_Id := Make_Temporary (Loc, 'A'); |
| |
| Use_Opaque_Representation : Boolean; |
| |
| begin |
| -- For a derived type, we can't go past the base type (to the |
| -- parent type) here, because that would cause the attribute's |
| -- formal parameter to have the wrong type; hence the Base_Type |
| -- check here. |
| |
| if Is_Itype (Typ) and then Typ /= Base_Type (Typ) then |
| Build_From_Any_Function |
| (Loc => Loc, |
| Typ => Etype (Typ), |
| Decl => Decl, |
| Fnam => Fnam); |
| return; |
| end if; |
| |
| Fnam := Make_Helper_Function_Name (Loc, Typ, Name_From_Any); |
| |
| Spec := |
| Make_Function_Specification (Loc, |
| Defining_Unit_Name => Fnam, |
| Parameter_Specifications => New_List ( |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => Any_Parameter, |
| Parameter_Type => New_Occurrence_Of (RTE (RE_Any), Loc))), |
| Result_Definition => New_Occurrence_Of (Typ, Loc)); |
| |
| -- The RACW case is taken care of by Exp_Dist.Add_RACW_From_Any |
| |
| pragma Assert |
| (not (Is_Remote_Access_To_Class_Wide_Type (Typ))); |
| |
| Use_Opaque_Representation := False; |
| |
| if Has_Stream_Attribute_Definition |
| (Typ, TSS_Stream_Output, At_Any_Place => True) |
| or else |
| Has_Stream_Attribute_Definition |
| (Typ, TSS_Stream_Write, At_Any_Place => True) |
| then |
| -- If user-defined stream attributes are specified for this |
| -- type, use them and transmit data as an opaque sequence of |
| -- stream elements. |
| |
| Use_Opaque_Representation := True; |
| |
| elsif Is_Derived_Type (Typ) and then not Is_Tagged_Type (Typ) then |
| Append_To (Stms, |
| Make_Simple_Return_Statement (Loc, |
| Expression => |
| OK_Convert_To (Typ, |
| Build_From_Any_Call |
| (Root_Type (Typ), |
| New_Occurrence_Of (Any_Parameter, Loc), |
| Decls)))); |
| |
| elsif Is_Record_Type (Typ) |
| and then not Is_Derived_Type (Typ) |
| and then not Is_Tagged_Type (Typ) |
| then |
| if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then |
| Append_To (Stms, |
| Make_Simple_Return_Statement (Loc, |
| Expression => |
| Build_From_Any_Call |
| (Etype (Typ), |
| New_Occurrence_Of (Any_Parameter, Loc), |
| Decls))); |
| |
| else |
| declare |
| Disc : Entity_Id := Empty; |
| Discriminant_Associations : List_Id; |
| Rdef : constant Node_Id := |
| Type_Definition |
| (Declaration_Node (Typ)); |
| Component_Counter : Nat := 0; |
| |
| -- The returned object |
| |
| Res : constant Entity_Id := Make_Temporary (Loc, 'R'); |
| |
| Res_Definition : Node_Id := New_Occurrence_Of (Typ, Loc); |
| |
| procedure FA_Rec_Add_Process_Element |
| (Stmts : List_Id; |
| Any : Entity_Id; |
| Counter : in out Nat; |
| Rec : Entity_Id; |
| Field : Node_Id); |
| |
| procedure FA_Append_Record_Traversal is |
| new Append_Record_Traversal |
| (Rec => Res, |
| Add_Process_Element => FA_Rec_Add_Process_Element); |
| |
| -------------------------------- |
| -- FA_Rec_Add_Process_Element -- |
| -------------------------------- |
| |
| procedure FA_Rec_Add_Process_Element |
| (Stmts : List_Id; |
| Any : Entity_Id; |
| Counter : in out Nat; |
| Rec : Entity_Id; |
| Field : Node_Id) |
| is |
| Ctyp : Entity_Id; |
| begin |
| if Nkind (Field) = N_Defining_Identifier then |
| -- A regular component |
| |
| Ctyp := Etype (Field); |
| |
| Append_To (Stmts, |
| Make_Assignment_Statement (Loc, |
| Name => Make_Selected_Component (Loc, |
| Prefix => |
| New_Occurrence_Of (Rec, Loc), |
| Selector_Name => |
| New_Occurrence_Of (Field, Loc)), |
| |
| Expression => |
| Build_From_Any_Call (Ctyp, |
| Build_Get_Aggregate_Element (Loc, |
| Any => Any, |
| TC => |
| Build_TypeCode_Call (Loc, Ctyp, Decls), |
| Idx => |
| Make_Integer_Literal (Loc, Counter)), |
| Decls))); |
| |
| else |
| -- A variant part |
| |
| declare |
| Variant : Node_Id; |
| Struct_Counter : Nat := 0; |
| |
| Block_Decls : constant List_Id := New_List; |
| Block_Stmts : constant List_Id := New_List; |
| VP_Stmts : List_Id; |
| |
| Alt_List : constant List_Id := New_List; |
| Choice_List : List_Id; |
| |
| Struct_Any : constant Entity_Id := |
| Make_Temporary (Loc, 'S'); |
| |
| begin |
| Append_To (Decls, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Struct_Any, |
| Constant_Present => True, |
| Object_Definition => |
| New_Occurrence_Of (RTE (RE_Any), Loc), |
| Expression => |
| Make_Function_Call (Loc, |
| Name => |
| New_Occurrence_Of |
| (RTE (RE_Extract_Union_Value), Loc), |
| |
| Parameter_Associations => New_List ( |
| Build_Get_Aggregate_Element (Loc, |
| Any => Any, |
| TC => |
| Make_Function_Call (Loc, |
| Name => New_Occurrence_Of ( |
| RTE (RE_Any_Member_Type), Loc), |
| Parameter_Associations => |
| New_List ( |
| New_Occurrence_Of (Any, Loc), |
| Make_Integer_Literal (Loc, |
| Intval => Counter))), |
| Idx => |
| Make_Integer_Literal (Loc, |
| Intval => Counter)))))); |
| |
| Append_To (Stmts, |
| Make_Block_Statement (Loc, |
| Declarations => Block_Decls, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => Block_Stmts))); |
| |
| Append_To (Block_Stmts, |
| Make_Case_Statement (Loc, |
| Expression => |
| Make_Selected_Component (Loc, |
| Prefix => Rec, |
| Selector_Name => Chars (Name (Field))), |
| Alternatives => Alt_List)); |
| |
| Variant := First_Non_Pragma (Variants (Field)); |
| while Present (Variant) loop |
| Choice_List := |
| New_Copy_List_Tree |
| (Discrete_Choices (Variant)); |
| |
| VP_Stmts := New_List; |
| |
| -- Struct_Counter should be reset before |
| -- handling a variant part. Indeed only one |
| -- of the case statement alternatives will be |
| -- executed at run time, so the counter must |
| -- start at 0 for every case statement. |
| |
| Struct_Counter := 0; |
| |
| FA_Append_Record_Traversal ( |
| Stmts => VP_Stmts, |
| Clist => Component_List (Variant), |
| Container => Struct_Any, |
| Counter => Struct_Counter); |
| |
| Append_To (Alt_List, |
| Make_Case_Statement_Alternative (Loc, |
| Discrete_Choices => Choice_List, |
| Statements => VP_Stmts)); |
| Next_Non_Pragma (Variant); |
| end loop; |
| end; |
| end if; |
| |
| Counter := Counter + 1; |
| end FA_Rec_Add_Process_Element; |
| |
| begin |
| -- First all discriminants |
| |
| if Has_Discriminants (Typ) then |
| Discriminant_Associations := New_List; |
| |
| Disc := First_Discriminant (Typ); |
| while Present (Disc) loop |
| declare |
| Disc_Var_Name : constant Entity_Id := |
| Make_Defining_Identifier (Loc, |
| Chars => Chars (Disc)); |
| Disc_Type : constant Entity_Id := |
| Etype (Disc); |
| |
| begin |
| Append_To (Decls, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Disc_Var_Name, |
| Constant_Present => True, |
| Object_Definition => |
| New_Occurrence_Of (Disc_Type, Loc), |
| |
| Expression => |
| Build_From_Any_Call (Disc_Type, |
| Build_Get_Aggregate_Element (Loc, |
| Any => Any_Parameter, |
| TC => Build_TypeCode_Call |
| (Loc, Disc_Type, Decls), |
| Idx => Make_Integer_Literal (Loc, |
| Intval => Component_Counter)), |
| Decls))); |
| |
| Component_Counter := Component_Counter + 1; |
| |
| Append_To (Discriminant_Associations, |
| Make_Discriminant_Association (Loc, |
| Selector_Names => New_List ( |
| New_Occurrence_Of (Disc, Loc)), |
| Expression => |
| New_Occurrence_Of (Disc_Var_Name, Loc))); |
| end; |
| Next_Discriminant (Disc); |
| end loop; |
| |
| Res_Definition := |
| Make_Subtype_Indication (Loc, |
| Subtype_Mark => Res_Definition, |
| Constraint => |
| Make_Index_Or_Discriminant_Constraint (Loc, |
| Discriminant_Associations)); |
| end if; |
| |
| -- Now we have all the discriminants in variables, we can |
| -- declared a constrained object. Note that we are not |
| -- initializing (non-discriminant) components directly in |
| -- the object declarations, because which fields to |
| -- initialize depends (at run time) on the discriminant |
| -- values. |
| |
| Append_To (Decls, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Res, |
| Object_Definition => Res_Definition)); |
| |
| -- ... then all components |
| |
| FA_Append_Record_Traversal (Stms, |
| Clist => Component_List (Rdef), |
| Container => Any_Parameter, |
| Counter => Component_Counter); |
| |
| Append_To (Stms, |
| Make_Simple_Return_Statement (Loc, |
| Expression => New_Occurrence_Of (Res, Loc))); |
| end; |
| end if; |
| |
| elsif Is_Array_Type (Typ) then |
| declare |
| Constrained : constant Boolean := Is_Constrained (Typ); |
| |
| procedure FA_Ary_Add_Process_Element |
| (Stmts : List_Id; |
| Any : Entity_Id; |
| Counter : Entity_Id; |
| Datum : Node_Id); |
| -- Assign the current element (as identified by Counter) of |
| -- Any to the variable denoted by name Datum, and advance |
| -- Counter by 1. If Datum is not an Any, a call to From_Any |
| -- for its type is inserted. |
| |
| -------------------------------- |
| -- FA_Ary_Add_Process_Element -- |
| -------------------------------- |
| |
| procedure FA_Ary_Add_Process_Element |
| (Stmts : List_Id; |
| Any : Entity_Id; |
| Counter : Entity_Id; |
| Datum : Node_Id) |
| is |
| Assignment : constant Node_Id := |
| Make_Assignment_Statement (Loc, |
| Name => Datum, |
| Expression => Empty); |
| |
| Element_Any : Node_Id; |
| |
| begin |
| declare |
| Element_TC : Node_Id; |
| |
| begin |
| if Etype (Datum) = RTE (RE_Any) then |
| |
| -- When Datum is an Any the Etype field is not |
| -- sufficient to determine the typecode of Datum |
| -- (which can be a TC_SEQUENCE or TC_ARRAY |
| -- depending on the value of Constrained). |
| |
| -- Therefore we retrieve the typecode which has |
| -- been constructed in Append_Array_Traversal with |
| -- a call to Get_Any_Type. |
| |
| Element_TC := |
| Make_Function_Call (Loc, |
| Name => New_Occurrence_Of ( |
| RTE (RE_Get_Any_Type), Loc), |
| Parameter_Associations => New_List ( |
| New_Occurrence_Of (Entity (Datum), Loc))); |
| else |
| -- For non Any Datum we simply construct a typecode |
| -- matching the Etype of the Datum. |
| |
| Element_TC := Build_TypeCode_Call |
| (Loc, Etype (Datum), Decls); |
| end if; |
| |
| Element_Any := |
| Build_Get_Aggregate_Element (Loc, |
| Any => Any, |
| TC => Element_TC, |
| Idx => New_Occurrence_Of (Counter, Loc)); |
| end; |
| |
| -- Note: here we *prepend* statements to Stmts, so |
| -- we must do it in reverse order. |
| |
| Prepend_To (Stmts, |
| Make_Assignment_Statement (Loc, |
| Name => |
| New_Occurrence_Of (Counter, Loc), |
| Expression => |
| Make_Op_Add (Loc, |
| Left_Opnd => New_Occurrence_Of (Counter, Loc), |
| Right_Opnd => Make_Integer_Literal (Loc, 1)))); |
| |
| if Nkind (Datum) /= N_Attribute_Reference then |
| |
| -- We ignore the value of the length of each |
| -- dimension, since the target array has already been |
| -- constrained anyway. |
| |
| if Etype (Datum) /= RTE (RE_Any) then |
| Set_Expression (Assignment, |
| Build_From_Any_Call |
| (Component_Type (Typ), Element_Any, Decls)); |
| else |
| Set_Expression (Assignment, Element_Any); |
| end if; |
| |
| Prepend_To (Stmts, Assignment); |
| end if; |
| end FA_Ary_Add_Process_Element; |
| |
| ------------------------ |
| -- Local Declarations -- |
| ------------------------ |
| |
| Counter : constant Entity_Id := |
| Make_Defining_Identifier (Loc, Name_J); |
| |
| Initial_Counter_Value : Int := 0; |
| |
| Component_TC : constant Entity_Id := |
| Make_Defining_Identifier (Loc, Name_T); |
| |
| Res : constant Entity_Id := |
| Make_Defining_Identifier (Loc, Name_R); |
| |
| procedure Append_From_Any_Array_Iterator is |
| new Append_Array_Traversal ( |
| Subprogram => Fnam, |
| Arry => Res, |
| Indexes => New_List, |
| Add_Process_Element => FA_Ary_Add_Process_Element); |
| |
| Res_Subtype_Indication : Node_Id := |
| New_Occurrence_Of (Typ, Loc); |
| |
| begin |
| if not Constrained then |
| declare |
| Ndim : constant Int := Number_Dimensions (Typ); |
| Lnam : Name_Id; |
| Hnam : Name_Id; |
| Indx : Node_Id := First_Index (Typ); |
| Indt : Entity_Id; |
| |
| Ranges : constant List_Id := New_List; |
| |
| begin |
| for J in 1 .. Ndim loop |
| Lnam := New_External_Name ('L', J); |
| Hnam := New_External_Name ('H', J); |
| |
| -- Note, for empty arrays bounds may be out of |
| -- the range of Etype (Indx). |
| |
| Indt := Base_Type (Etype (Indx)); |
| |
| Append_To (Decls, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, Lnam), |
| Constant_Present => True, |
| Object_Definition => |
| New_Occurrence_Of (Indt, Loc), |
| Expression => |
| Build_From_Any_Call |
| (Indt, |
| Build_Get_Aggregate_Element (Loc, |
| Any => Any_Parameter, |
| TC => Build_TypeCode_Call |
| (Loc, Indt, Decls), |
| Idx => |
| Make_Integer_Literal (Loc, J - 1)), |
| Decls))); |
| |
| Append_To (Decls, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, Hnam), |
| |
| Constant_Present => True, |
| |
| Object_Definition => |
| New_Occurrence_Of (Indt, Loc), |
| |
| Expression => Make_Attribute_Reference (Loc, |
| Prefix => |
| New_Occurrence_Of (Indt, Loc), |
| |
| Attribute_Name => Name_Val, |
| |
| Expressions => New_List ( |
| Make_Op_Subtract (Loc, |
| Left_Opnd => |
| Make_Op_Add (Loc, |
| Left_Opnd => |
| OK_Convert_To |
| (Standard_Long_Integer, |
| Make_Identifier (Loc, Lnam)), |
| |
| Right_Opnd => |
| OK_Convert_To |
| (Standard_Long_Integer, |
| Make_Function_Call (Loc, |
| Name => |
| New_Occurrence_Of (RTE ( |
| RE_Get_Nested_Sequence_Length |
| ), Loc), |
| Parameter_Associations => |
| New_List ( |
| New_Occurrence_Of ( |
| Any_Parameter, Loc), |
| Make_Integer_Literal (Loc, |
| Intval => J))))), |
| |
| Right_Opnd => |
| Make_Integer_Literal (Loc, 1)))))); |
| |
| Append_To (Ranges, |
| Make_Range (Loc, |
| Low_Bound => Make_Identifier (Loc, Lnam), |
| High_Bound => Make_Identifier (Loc, Hnam))); |
| |
| Next_Index (Indx); |
| end loop; |
| |
| -- Now we have all the necessary bound information: |
| -- apply the set of range constraints to the |
| -- (unconstrained) nominal subtype of Res. |
| |
| Initial_Counter_Value := Ndim; |
| Res_Subtype_Indication := Make_Subtype_Indication (Loc, |
| Subtype_Mark => Res_Subtype_Indication, |
| Constraint => |
| Make_Index_Or_Discriminant_Constraint (Loc, |
| Constraints => Ranges)); |
| end; |
| end if; |
| |
| Append_To (Decls, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Res, |
| Object_Definition => Res_Subtype_Indication)); |
| Set_Etype (Res, Typ); |
| |
| Append_To (Decls, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Counter, |
| Object_Definition => |
| New_Occurrence_Of (RTE (RE_Unsigned_32), Loc), |
| Expression => |
| Make_Integer_Literal (Loc, Initial_Counter_Value))); |
| |
| Append_To (Decls, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Component_TC, |
| Constant_Present => True, |
| Object_Definition => |
| New_Occurrence_Of (RTE (RE_TypeCode), Loc), |
| Expression => |
| Build_TypeCode_Call (Loc, |
| Component_Type (Typ), Decls))); |
| |
| Append_From_Any_Array_Iterator |
| (Stms, Any_Parameter, Counter); |
| |
| Append_To (Stms, |
| Make_Simple_Return_Statement (Loc, |
| Expression => New_Occurrence_Of (Res, Loc))); |
| end; |
| |
| elsif Is_Integer_Type (Typ) or else Is_Unsigned_Type (Typ) then |
| Append_To (Stms, |
| Make_Simple_Return_Statement (Loc, |
| Expression => |
| Unchecked_Convert_To (Typ, |
| Build_From_Any_Call |
| (Find_Numeric_Representation (Typ), |
| New_Occurrence_Of (Any_Parameter, Loc), |
| Decls)))); |
| |
| else |
| Use_Opaque_Representation := True; |
| end if; |
| |
| if Use_Opaque_Representation then |
| Assign_Opaque_From_Any (Loc, |
| Stms => Stms, |
| Typ => Typ, |
| N => New_Occurrence_Of (Any_Parameter, Loc), |
| Target => Empty); |
| end if; |
| |
| Decl := |
| Make_Subprogram_Body (Loc, |
| Specification => Spec, |
| Declarations => Decls, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => Stms)); |
| end Build_From_Any_Function; |
| |
| --------------------------------- |
| -- Build_Get_Aggregate_Element -- |
| --------------------------------- |
| |
| function Build_Get_Aggregate_Element |
| (Loc : Source_Ptr; |
| Any : Entity_Id; |
| TC : Node_Id; |
| Idx : Node_Id) return Node_Id |
| is |
| begin |
| return Make_Function_Call (Loc, |
| Name => |
| New_Occurrence_Of (RTE (RE_Get_Aggregate_Element), Loc), |
| Parameter_Associations => New_List ( |
| New_Occurrence_Of (Any, Loc), |
| TC, |
| Idx)); |
| end Build_Get_Aggregate_Element; |
| |
| ---------------------------------- |
| -- Build_Name_And_Repository_Id -- |
| ---------------------------------- |
| |
| procedure Build_Name_And_Repository_Id |
| (E : Entity_Id; |
| Name_Str : out String_Id; |
| Repo_Id_Str : out String_Id) |
| is |
| begin |
| Name_Str := Fully_Qualified_Name_String (E, Append_NUL => False); |
| Start_String; |
| Store_String_Chars ("DSA:"); |
| Store_String_Chars (Name_Str); |
| Store_String_Chars (":1.0"); |
| Repo_Id_Str := End_String; |
| end Build_Name_And_Repository_Id; |
| |
| ----------------------- |
| -- Build_To_Any_Call -- |
| ----------------------- |
| |
| function Build_To_Any_Call |
| (Loc : Source_Ptr; |
| N : Node_Id; |
| Decls : List_Id; |
| Constrained : Boolean := False) return Node_Id |
| is |
| Typ : Entity_Id := Etype (N); |
| U_Type : Entity_Id; |
| C_Type : Entity_Id; |
| Fnam : Entity_Id; |
| Lib_RE : RE_Id := RE_Null; |
| |
| begin |
| -- If N is a selected component, then maybe its Etype has not been |
| -- set yet: try to use Etype of the selector_name in that case. |
| |
| if No (Typ) and then Nkind (N) = N_Selected_Component then |
| Typ := Etype (Selector_Name (N)); |
| end if; |
| |
| pragma Assert (Present (Typ)); |
| |
| -- Get full view for private type, completion for incomplete type |
| |
| U_Type := Underlying_Type (Typ); |
| |
| -- First simple case where the To_Any function is present in the |
| -- type's TSS. |
| |
| Fnam := Find_Inherited_TSS (U_Type, TSS_To_Any); |
| |
| -- For the subtype representing a generic actual type, go to the |
| -- actual type. |
| |
| if Is_Generic_Actual_Subtype (U_Type) then |
| U_Type := Underlying_Type (Base_Type (U_Type)); |
| end if; |
| |
| -- For a standard subtype, go to the base type |
| |
| if Sloc (U_Type) <= Standard_Location then |
| U_Type := Base_Type (U_Type); |
| |
| -- For a user subtype, go to first subtype |
| |
| elsif Comes_From_Source (U_Type) |
| and then Nkind (Declaration_Node (U_Type)) |
| = N_Subtype_Declaration |
| then |
| U_Type := First_Subtype (U_Type); |
| end if; |
| |
| if Present (Fnam) then |
| null; |
| |
| -- Check first for Boolean and Character. These are enumeration |
| -- types, but we treat them specially, since they may require |
| -- special handling in the transfer protocol. However, this |
| -- special handling only applies if they have standard |
| -- representation, otherwise they are treated like any other |
| -- enumeration type. |
| |
| elsif U_Type = Standard_Boolean then |
| Lib_RE := RE_TA_B; |
| |
| elsif U_Type = Standard_Character then |
| Lib_RE := RE_TA_C; |
| |
| elsif U_Type = Standard_Wide_Character then |
| Lib_RE := RE_TA_WC; |
| |
| elsif U_Type = Standard_Wide_Wide_Character then |
| Lib_RE := RE_TA_WWC; |
| |
| -- Floating point types |
| |
| elsif U_Type = Standard_Short_Float then |
| Lib_RE := RE_TA_SF; |
| |
| elsif U_Type = Standard_Float then |
| Lib_RE := RE_TA_F; |
| |
| elsif U_Type = Standard_Long_Float then |
| Lib_RE := RE_TA_LF; |
| |
| elsif U_Type = Standard_Long_Long_Float then |
| Lib_RE := RE_TA_LLF; |
| |
| -- Integer types |
| |
| elsif U_Type = RTE (RE_Integer_8) then |
| Lib_RE := RE_TA_I8; |
| |
| elsif U_Type = RTE (RE_Integer_16) then |
| Lib_RE := RE_TA_I16; |
| |
| elsif U_Type = RTE (RE_Integer_32) then |
| Lib_RE := RE_TA_I32; |
| |
| elsif U_Type = RTE (RE_Integer_64) then |
| Lib_RE := RE_TA_I64; |
| |
| -- Unsigned integer types |
| |
| elsif U_Type = RTE (RE_Unsigned_8) then |
| Lib_RE := RE_TA_U8; |
| |
| elsif U_Type = RTE (RE_Unsigned_16) then |
| Lib_RE := RE_TA_U16; |
| |
| elsif U_Type = RTE (RE_Unsigned_32) then |
| Lib_RE := RE_TA_U32; |
| |
| elsif U_Type = RTE (RE_Unsigned_64) then |
| Lib_RE := RE_TA_U64; |
| |
| elsif Is_RTE (U_Type, RE_Unbounded_String) then |
| Lib_RE := RE_TA_String; |
| |
| -- Special DSA types |
| |
| elsif Is_RTE (U_Type, RE_Any_Container_Ptr) then |
| Lib_RE := RE_TA_A; |
| U_Type := Typ; |
| |
| elsif U_Type = Underlying_Type (RTE (RE_TypeCode)) then |
| |
| -- No corresponding FA_TC ??? |
| |
| Lib_RE := RE_TA_TC; |
| |
| -- Other (non-primitive) types |
| |
| else |
| declare |
| Decl : Entity_Id; |
| begin |
| Build_To_Any_Function (Loc, U_Type, Decl, Fnam); |
| Append_To (Decls, Decl); |
| end; |
| end if; |
| |
| -- Call the function |
| |
| if Lib_RE /= RE_Null then |
| pragma Assert (No (Fnam)); |
| Fnam := RTE (Lib_RE); |
| end if; |
| |
| -- If Fnam is already analyzed, find the proper expected type, |
| -- else we have a newly constructed To_Any function and we know |
| -- that the expected type of its parameter is U_Type. |
| |
| if Ekind (Fnam) = E_Function |
| and then Present (First_Formal (Fnam)) |
| then |
| C_Type := Etype (First_Formal (Fnam)); |
| else |
| C_Type := U_Type; |
| end if; |
| |
| declare |
| Params : constant List_Id := |
| New_List (OK_Convert_To (C_Type, N)); |
| begin |
| if Is_Limited_Type (C_Type) then |
| Append_To (Params, |
| New_Occurrence_Of (Boolean_Literals (Constrained), Loc)); |
| end if; |
| |
| return |
| Make_Function_Call (Loc, |
| Name => New_Occurrence_Of (Fnam, Loc), |
| Parameter_Associations => Params); |
| end; |
| end Build_To_Any_Call; |
| |
| --------------------------- |
| -- Build_To_Any_Function -- |
| --------------------------- |
| |
| procedure Build_To_Any_Function |
| (Loc : Source_Ptr; |
| Typ : Entity_Id; |
| Decl : out Node_Id; |
| Fnam : out Entity_Id) |
| is |
| Spec : Node_Id; |
| Params : List_Id; |
| Decls : List_Id; |
| Stms : List_Id; |
| |
| Expr_Formal : Entity_Id; |
| Cstr_Formal : Entity_Id := Empty; -- initialize to prevent warning |
| Any : Entity_Id; |
| Result_TC : Node_Id; |
| |
| Any_Decl : Node_Id; |
| |
| Use_Opaque_Representation : Boolean; |
| -- When True, use stream attributes and represent type as an |
| -- opaque sequence of bytes. |
| |
| begin |
| -- For a derived type, we can't go past the base type (to the |
| -- parent type) here, because that would cause the attribute's |
| -- formal parameter to have the wrong type; hence the Base_Type |
| -- check here. |
| |
| if Is_Itype (Typ) and then Typ /= Base_Type (Typ) then |
| Build_To_Any_Function |
| (Loc => Loc, |
| Typ => Etype (Typ), |
| Decl => Decl, |
| Fnam => Fnam); |
| return; |
| end if; |
| |
| Decls := New_List; |
| Stms := New_List; |
| |
| Any := Make_Defining_Identifier (Loc, Name_A); |
| Result_TC := Build_TypeCode_Call (Loc, Typ, Decls); |
| |
| Fnam := Make_Helper_Function_Name (Loc, Typ, Name_To_Any); |
| |
| Expr_Formal := Make_Defining_Identifier (Loc, Name_E); |
| Params := New_List ( |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => Expr_Formal, |
| Parameter_Type => New_Occurrence_Of (Typ, Loc))); |
| Set_Etype (Expr_Formal, Typ); |
| |
| if Is_Limited_Type (Typ) then |
| Cstr_Formal := Make_Defining_Identifier (Loc, Name_C); |
| Append_To (Params, |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => Cstr_Formal, |
| Parameter_Type => |
| New_Occurrence_Of (Standard_Boolean, Loc))); |
| end if; |
| |
| Spec := |
| Make_Function_Specification (Loc, |
| Defining_Unit_Name => Fnam, |
| Parameter_Specifications => Params, |
| Result_Definition => |
| New_Occurrence_Of (RTE (RE_Any), Loc)); |
| |
| Any_Decl := |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Any, |
| Object_Definition => New_Occurrence_Of (RTE (RE_Any), Loc)); |
| |
| Use_Opaque_Representation := False; |
| |
| if Has_Stream_Attribute_Definition |
| (Typ, TSS_Stream_Output, At_Any_Place => True) |
| or else |
| Has_Stream_Attribute_Definition |
| (Typ, TSS_Stream_Write, At_Any_Place => True) |
| then |
| -- If user-defined stream attributes are specified for this |
| -- type, use them and transmit data as an opaque sequence of |
| -- stream elements. |
| |
| Use_Opaque_Representation := True; |
| |
| elsif Is_Derived_Type (Typ) and then not Is_Tagged_Type (Typ) then |
| |
| -- Untagged derived type: convert to root type |
| |
| declare |
| Rt_Type : constant Entity_Id := Root_Type (Typ); |
| Expr : constant Node_Id := |
| OK_Convert_To |
| (Rt_Type, |
| New_Occurrence_Of (Expr_Formal, Loc)); |
| begin |
| Set_Expression (Any_Decl, |
| Build_To_Any_Call (Loc, Expr, Decls)); |
| end; |
| |
| elsif Is_Record_Type (Typ) and then not Is_Tagged_Type (Typ) then |
| |
| -- Untagged record type |
| |
| if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then |
| declare |
| Rt_Type : constant Entity_Id := Etype (Typ); |
| Expr : constant Node_Id := |
| OK_Convert_To (Rt_Type, |
| New_Occurrence_Of (Expr_Formal, Loc)); |
| |
| begin |
| Set_Expression |
| (Any_Decl, Build_To_Any_Call (Loc, Expr, Decls)); |
| end; |
| |
| -- Comment needed here (and label on declare block ???) |
| |
| else |
| declare |
| Disc : Entity_Id := Empty; |
| Rdef : constant Node_Id := |
| Type_Definition (Declaration_Node (Typ)); |
| Counter : Nat := 0; |
| Elements : constant List_Id := New_List; |
| |
| procedure TA_Rec_Add_Process_Element |
| (Stmts : List_Id; |
| Container : Node_Or_Entity_Id; |
| Counter : in out Nat; |
| Rec : Entity_Id; |
| Field : Node_Id); |
| -- Processing routine for traversal below |
| |
| procedure TA_Append_Record_Traversal is |
| new Append_Record_Traversal |
| (Rec => Expr_Formal, |
| Add_Process_Element => TA_Rec_Add_Process_Element); |
| |
| -------------------------------- |
| -- TA_Rec_Add_Process_Element -- |
| -------------------------------- |
| |
| procedure TA_Rec_Add_Process_Element |
| (Stmts : List_Id; |
| Container : Node_Or_Entity_Id; |
| Counter : in out Nat; |
| Rec : Entity_Id; |
| Field : Node_Id) |
| is |
| Field_Ref : Node_Id; |
| |
| begin |
| if Nkind (Field) = N_Defining_Identifier then |
| |
| -- A regular component |
| |
| Field_Ref := Make_Selected_Component (Loc, |
| Prefix => New_Occurrence_Of (Rec, Loc), |
| Selector_Name => New_Occurrence_Of (Field, Loc)); |
| Set_Etype (Field_Ref, Etype (Field)); |
| |
| Append_To (Stmts, |
| Make_Procedure_Call_Statement (Loc, |
| Name => |
| New_Occurrence_Of ( |
| RTE (RE_Add_Aggregate_Element), Loc), |
| Parameter_Associations => New_List ( |
| New_Occurrence_Of (Container, Loc), |
| Build_To_Any_Call (Loc, Field_Ref, Decls)))); |
| |
| else |
| -- A variant part |
| |
| Variant_Part : declare |
| Variant : Node_Id; |
| Struct_Counter : Nat := 0; |
| |
| Block_Decls : constant List_Id := New_List; |
| Block_Stmts : constant List_Id := New_List; |
| VP_Stmts : List_Id; |
| |
| Alt_List : constant List_Id := New_List; |
| Choice_List : List_Id; |
| |
| Union_Any : constant Entity_Id := |
| Make_Temporary (Loc, 'V'); |
| |
| Struct_Any : constant Entity_Id := |
| Make_Temporary (Loc, 'S'); |
| |
| function Make_Discriminant_Reference |
| return Node_Id; |
| -- Build reference to the discriminant for this |
| -- variant part. |
| |
| --------------------------------- |
| -- Make_Discriminant_Reference -- |
| --------------------------------- |
| |
| function Make_Discriminant_Reference |
| return Node_Id |
| is |
| Nod : constant Node_Id := |
| Make_Selected_Component (Loc, |
| Prefix => Rec, |
| Selector_Name => |
| Chars (Name (Field))); |
| begin |
| Set_Etype (Nod, Etype (Name (Field))); |
| return Nod; |
| end Make_Discriminant_Reference; |
| |
| -- Start of processing for Variant_Part |
| |
| begin |
| Append_To (Stmts, |
| Make_Block_Statement (Loc, |
| Declarations => |
| Block_Decls, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => Block_Stmts))); |
| |
| -- Declare variant part aggregate (Union_Any). |
| -- Knowing the position of this VP in the |
| -- variant record, we can fetch the VP typecode |
| -- from Container. |
| |
| Append_To (Block_Decls, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Union_Any, |
| Object_Definition => |
| New_Occurrence_Of (RTE (RE_Any), Loc), |
| Expression => |
| Make_Function_Call (Loc, |
| Name => New_Occurrence_Of ( |
| RTE (RE_Create_Any), Loc), |
| Parameter_Associations => New_List ( |
| Make_Function_Call (Loc, |
| Name => |
| New_Occurrence_Of ( |
| RTE (RE_Any_Member_Type), Loc), |
| Parameter_Associations => New_List ( |
| New_Occurrence_Of (Container, Loc), |
| Make_Integer_Literal (Loc, |
| Counter))))))); |
| |
| -- Declare inner struct aggregate (which |
| -- contains the components of this VP). |
| |
| Append_To (Block_Decls, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Struct_Any, |
| Object_Definition => |
| New_Occurrence_Of (RTE (RE_Any), Loc), |
| Expression => |
| Make_Function_Call (Loc, |
| Name => New_Occurrence_Of ( |
| RTE (RE_Create_Any), Loc), |
| Parameter_Associations => New_List ( |
| Make_Function_Call (Loc, |
| Name => |
| New_Occurrence_Of ( |
| RTE (RE_Any_Member_Type), Loc), |
| Parameter_Associations => New_List ( |
| New_Occurrence_Of (Union_Any, Loc), |
| Make_Integer_Literal (Loc, |
| Uint_1))))))); |
| |
| -- Build case statement |
| |
| Append_To (Block_Stmts, |
| Make_Case_Statement (Loc, |
| Expression => Make_Discriminant_Reference, |
| Alternatives => Alt_List)); |
| |
| Variant := First_Non_Pragma (Variants (Field)); |
| while Present (Variant) loop |
| Choice_List := New_Copy_List_Tree |
| (Discrete_Choices (Variant)); |
| |
| VP_Stmts := New_List; |
| |
| -- Append discriminant val to union aggregate |
| |
| Append_To (VP_Stmts, |
| Make_Procedure_Call_Statement (Loc, |
| Name => |
| New_Occurrence_Of ( |
| RTE (RE_Add_Aggregate_Element), Loc), |
| Parameter_Associations => New_List ( |
| New_Occurrence_Of (Union_Any, Loc), |
| Build_To_Any_Call |
| (Loc, |
| Make_Discriminant_Reference, |
| Block_Decls)))); |
| |
| -- Populate inner struct aggregate |
| |
| -- Struct_Counter should be reset before |
| -- handling a variant part. Indeed only one |
| -- of the case statement alternatives will be |
| -- executed at run time, so the counter must |
| -- start at 0 for every case statement. |
| |
| Struct_Counter := 0; |
| |
| TA_Append_Record_Traversal |
| (Stmts => VP_Stmts, |
| Clist => Component_List (Variant), |
| Container => Struct_Any, |
| Counter => Struct_Counter); |
| |
| -- Append inner struct to union aggregate |
| |
| Append_To (VP_Stmts, |
| Make_Procedure_Call_Statement (Loc, |
| Name => |
| New_Occurrence_Of |
| (RTE (RE_Add_Aggregate_Element), Loc), |
| Parameter_Associations => New_List ( |
| New_Occurrence_Of (Union_Any, Loc), |
| New_Occurrence_Of (Struct_Any, Loc)))); |
| |
| -- Append union to outer aggregate |
| |
| Append_To (VP_Stmts, |
| Make_Procedure_Call_Statement (Loc, |
| Name => |
| New_Occurrence_Of |
| (RTE (RE_Add_Aggregate_Element), Loc), |
| Parameter_Associations => New_List ( |
| New_Occurrence_Of (Container, Loc), |
| New_Occurrence_Of |
| (Union_Any, Loc)))); |
| |
| Append_To (Alt_List, |
| Make_Case_Statement_Alternative (Loc, |
| Discrete_Choices => Choice_List, |
| Statements => VP_Stmts)); |
| |
| Next_Non_Pragma (Variant); |
| end loop; |
| end Variant_Part; |
| end if; |
| |
| Counter := Counter + 1; |
| end TA_Rec_Add_Process_Element; |
| |
| begin |
| -- Records are encoded in a TC_STRUCT aggregate: |
| |
| -- -- Outer aggregate (TC_STRUCT) |
| -- | [discriminant1] |
| -- | [discriminant2] |
| -- | ... |
| -- | |
| -- | [component1] |
| -- | [component2] |
| -- | ... |
| |
| -- A component can be a common component or variant part |
| |
| -- A variant part is encoded as a TC_UNION aggregate: |
| |
| -- -- Variant Part Aggregate (TC_UNION) |
| -- | [discriminant choice for this Variant Part] |
| -- | |
| -- | -- Inner struct (TC_STRUCT) |
| -- | | [component1] |
| -- | | [component2] |
| -- | | ... |
| |
| -- Let's start by building the outer aggregate. First we |
| -- construct Elements array containing all discriminants. |
| |
| if Has_Discriminants (Typ) then |
| Disc := First_Discriminant (Typ); |
| while Present (Disc) loop |
| declare |
| Discriminant : constant Entity_Id := |
| Make_Selected_Component (Loc, |
| Prefix => Expr_Formal, |
| Selector_Name => Chars (Disc)); |
| begin |
| Set_Etype (Discriminant, Etype (Disc)); |
| Append_To (Elements, |
| Make_Component_Association (Loc, |
| Choices => New_List ( |
| Make_Integer_Literal (Loc, Counter)), |
| Expression => |
| Build_To_Any_Call (Loc, |
| Discriminant, Decls))); |
| end; |
| |
| Counter := Counter + 1; |
| Next_Discriminant (Disc); |
| end loop; |
| |
| else |
| -- If there are no discriminants, we declare an empty |
| -- Elements array. |
| |
| declare |
| Dummy_Any : constant Entity_Id := |
| Make_Temporary (Loc, 'A'); |
| |
| begin |
| Append_To (Decls, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Dummy_Any, |
| Object_Definition => |
| New_Occurrence_Of (RTE (RE_Any), Loc))); |
| |
| Append_To (Elements, |
| Make_Component_Association (Loc, |
| Choices => New_List ( |
| Make_Range (Loc, |
| Low_Bound => |
| Make_Integer_Literal (Loc, 1), |
| High_Bound => |
| Make_Integer_Literal (Loc, 0))), |
| Expression => |
| New_Occurrence_Of (Dummy_Any, Loc))); |
| end; |
| end if; |
| |
| -- We build the result aggregate with discriminants |
| -- as the first elements. |
| |
| Set_Expression (Any_Decl, |
| Make_Function_Call (Loc, |
| Name => New_Occurrence_Of |
| (RTE (RE_Any_Aggregate_Build), Loc), |
| Parameter_Associations => New_List ( |
| Result_TC, |
| Make_Aggregate (Loc, |
| Component_Associations => Elements)))); |
| Result_TC := Empty; |
| |
| -- Then we append all the components to the result |
| -- aggregate. |
| |
| TA_Append_Record_Traversal (Stms, |
| Clist => Component_List (Rdef), |
| Container => Any, |
| Counter => Counter); |
| end; |
| end if; |
| |
| elsif Is_Array_Type (Typ) then |
| |
| -- Constrained and unconstrained array types |
| |
| declare |
| Constrained : constant Boolean := |
| not Transmit_As_Unconstrained (Typ); |
| |
| procedure TA_Ary_Add_Process_Element |
| (Stmts : List_Id; |
| Any : Entity_Id; |
| Counter : Entity_Id; |
| Datum : Node_Id); |
| |
| -------------------------------- |
| -- TA_Ary_Add_Process_Element -- |
| -------------------------------- |
| |
| procedure TA_Ary_Add_Process_Element |
| (Stmts : List_Id; |
| Any : Entity_Id; |
| Counter : Entity_Id; |
| Datum : Node_Id) |
| is |
| pragma Unreferenced (Counter); |
| |
| Element_Any : Node_Id; |
| |
| begin |
| if Etype (Datum) = RTE (RE_Any) then |
| Element_Any := Datum; |
| else |
| Element_Any := Build_To_Any_Call (Loc, Datum, Decls); |
| end if; |
| |
| Append_To (Stmts, |
| Make_Procedure_Call_Statement (Loc, |
| Name => New_Occurrence_Of ( |
| RTE (RE_Add_Aggregate_Element), Loc), |
| Parameter_Associations => New_List ( |
| New_Occurrence_Of (Any, Loc), |
| Element_Any))); |
| end TA_Ary_Add_Process_Element; |
| |
| procedure Append_To_Any_Array_Iterator is |
| new Append_Array_Traversal ( |
| Subprogram => Fnam, |
| Arry => Expr_Formal, |
| Indexes => New_List, |
| Add_Process_Element => TA_Ary_Add_Process_Element); |
| |
| Index : Node_Id; |
| |
| begin |
| Set_Expression (Any_Decl, |
| Make_Function_Call (Loc, |
| Name => |
| New_Occurrence_Of (RTE (RE_Create_Any), Loc), |
| Parameter_Associations => New_List (Result_TC))); |
| Result_TC := Empty; |
| |
| if not Constrained then |
| Index := First_Index (Typ); |
| for J in 1 .. Number_Dimensions (Typ) loop |
| Append_To (Stms, |
| Make_Procedure_Call_Statement (Loc, |
| Name => |
| New_Occurrence_Of |
| (RTE (RE_Add_Aggregate_Element), Loc), |
| Parameter_Associations => New_List ( |
| New_Occurrence_Of (Any, Loc), |
| Build_To_Any_Call (Loc, |
| OK_Convert_To (Etype (Index), |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| New_Occurrence_Of (Expr_Formal, Loc), |
| Attribute_Name => Name_First, |
| Expressions => New_List ( |
| Make_Integer_Literal (Loc, J)))), |
| Decls)))); |
| Next_Index (Index); |
| end loop; |
| end if; |
| |
| Append_To_Any_Array_Iterator (Stms, Any); |
| end; |
| |
| elsif Is_Integer_Type (Typ) or else Is_Unsigned_Type (Typ) then |
| |
| -- Integer types |
| |
| Set_Expression (Any_Decl, |
| Build_To_Any_Call (Loc, |
| OK_Convert_To ( |
| Find_Numeric_Representation (Typ), |
| New_Occurrence_Of (Expr_Formal, Loc)), |
| Decls)); |
| |
| else |
| -- Default case, including tagged types: opaque representation |
| |
| Use_Opaque_Representation := True; |
| end if; |
| |
| if Use_Opaque_Representation then |
| declare |
| Strm : constant Entity_Id := Make_Temporary (Loc, 'S'); |
| -- Stream used to store data representation produced by |
| -- stream attribute. |
| |
| begin |
| -- Generate: |
| -- Strm : aliased Buffer_Stream_Type; |
| |
| Append_To (Decls, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Strm, |
| Aliased_Present => True, |
| Object_Definition => |
| New_Occurrence_Of (RTE (RE_Buffer_Stream_Type), Loc))); |
| |
| -- Generate: |
| -- T'Output (Strm'Access, E); |
| -- or |
| -- T'Write (Strm'Access, E); |
| -- depending on whether to transmit as unconstrained. |
| |
| -- For limited types, select at run time depending on |
| -- Constrained parameter. |
| |
| declare |
| function Stream_Call (Attr : Name_Id) return Node_Id; |
| -- Return a call to the named attribute |
| |
| ----------------- |
| -- Stream_Call -- |
| ----------------- |
| |
| function Stream_Call (Attr : Name_Id) return Node_Id is |
| begin |
| return Make_Attribute_Reference (Loc, |
| Prefix => |
| New_Occurrence_Of (Typ, Loc), |
| Attribute_Name => Attr, |
| Expressions => New_List ( |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| New_Occurrence_Of (Strm, Loc), |
| Attribute_Name => Name_Access), |
| New_Occurrence_Of (Expr_Formal, Loc))); |
| |
| end Stream_Call; |
| |
| begin |
| if Is_Limited_Type (Typ) then |
| Append_To (Stms, |
| Make_Implicit_If_Statement (Typ, |
| Condition => |
| New_Occurrence_Of (Cstr_Formal, Loc), |
| Then_Statements => New_List ( |
| Stream_Call (Name_Write)), |
| Else_Statements => New_List ( |
| Stream_Call (Name_Output)))); |
| |
| elsif Transmit_As_Unconstrained (Typ) then |
| Append_To (Stms, Stream_Call (Name_Output)); |
| |
| else |
| Append_To (Stms, Stream_Call (Name_Write)); |
| end if; |
| end; |
| |
| -- Generate: |
| -- BS_To_Any (Strm, A); |
| |
| Append_To (Stms, |
| Make_Procedure_Call_Statement (Loc, |
| Name => |
| New_Occurrence_Of (RTE (RE_BS_To_Any), Loc), |
| Parameter_Associations => New_List ( |
| New_Occurrence_Of (Strm, Loc), |
| New_Occurrence_Of (Any, Loc)))); |
| |
| -- Generate: |
| -- Release_Buffer (Strm); |
| |
| Append_To (Stms, |
| Make_Procedure_Call_Statement (Loc, |
| Name => |
| New_Occurrence_Of (RTE (RE_Release_Buffer), Loc), |
| Parameter_Associations => New_List ( |
| New_Occurrence_Of (Strm, Loc)))); |
| end; |
| end if; |
| |
| Append_To (Decls, Any_Decl); |
| |
| if Present (Result_TC) then |
| Append_To (Stms, |
| Make_Procedure_Call_Statement (Loc, |
| Name => |
| New_Occurrence_Of (RTE (RE_Set_TC), Loc), |
| Parameter_Associations => New_List ( |
| New_Occurrence_Of (Any, Loc), |
| Result_TC))); |
| end if; |
| |
| Append_To (Stms, |
| Make_Simple_Return_Statement (Loc, |
| Expression => New_Occurrence_Of (Any, Loc))); |
| |
| Decl := |
| Make_Subprogram_Body (Loc, |
| Specification => Spec, |
| Declarations => Decls, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => Stms)); |
| end Build_To_Any_Function; |
| |
| ------------------------- |
| -- Build_TypeCode_Call -- |
| ------------------------- |
| |
| function Build_TypeCode_Call |
| (Loc : Source_Ptr; |
| Typ : Entity_Id; |
| Decls : List_Id) return Node_Id |
| is |
| U_Type : Entity_Id := Underlying_Type (Typ); |
| -- The full view, if Typ is private; the completion, |
| -- if Typ is incomplete. |
| |
| Fnam : Entity_Id; |
| Lib_RE : RE_Id := RE_Null; |
| Expr : Node_Id; |
| |
| begin |
| -- Special case System.PolyORB.Interface.Any: its primitives have |
| -- not been set yet, so can't call Find_Inherited_TSS. |
| |
| if Typ = RTE (RE_Any) then |
| Fnam := RTE (RE_TC_A); |
| |
| else |
| -- First simple case where the TypeCode is present |
| -- in the type's TSS. |
| |
| Fnam := Find_Inherited_TSS (U_Type, TSS_TypeCode); |
| end if; |
| |
| -- For the subtype representing a generic actual type, go to the |
| -- actual type. |
| |
| if Is_Generic_Actual_Subtype (U_Type) then |
| U_Type := Underlying_Type (Base_Type (U_Type)); |
| end if; |
| |
| -- For a standard subtype, go to the base type |
| |
| if Sloc (U_Type) <= Standard_Location then |
| U_Type := Base_Type (U_Type); |
| |
| -- For a user subtype, go to first subtype |
| |
| elsif Comes_From_Source (U_Type) |
| and then Nkind (Declaration_Node (U_Type)) |
| = N_Subtype_Declaration |
| then |
| U_Type := First_Subtype (U_Type); |
| end if; |
| |
| if No (Fnam) then |
| if U_Type = Standard_Boolean then |
| Lib_RE := RE_TC_B; |
| |
| elsif U_Type = Standard_Character then |
| Lib_RE := RE_TC_C; |
| |
| elsif U_Type = Standard_Wide_Character then |
| Lib_RE := RE_TC_WC; |
| |
| elsif U_Type = Standard_Wide_Wide_Character then |
| Lib_RE := RE_TC_WWC; |
| |
| -- Floating point types |
| |
| elsif U_Type = Standard_Short_Float then |
| Lib_RE := RE_TC_SF; |
| |
| elsif U_Type = Standard_Float then |
| Lib_RE := RE_TC_F; |
| |
| elsif U_Type = Standard_Long_Float then |
| Lib_RE := RE_TC_LF; |
| |
| elsif U_Type = Standard_Long_Long_Float then |
| Lib_RE := RE_TC_LLF; |
| |
| -- Integer types (walk back to the base type) |
| |
| elsif U_Type = RTE (RE_Integer_8) then |
| Lib_RE := RE_TC_I8; |
| |
| elsif U_Type = RTE (RE_Integer_16) then |
| Lib_RE := RE_TC_I16; |
| |
| elsif U_Type = RTE (RE_Integer_32) then |
| Lib_RE := RE_TC_I32; |
| |
| elsif U_Type = RTE (RE_Integer_64) then |
| Lib_RE := RE_TC_I64; |
| |
| -- Unsigned integer types |
| |
| elsif U_Type = RTE (RE_Unsigned_8) then |
| Lib_RE := RE_TC_U8; |
| |
| elsif U_Type = RTE (RE_Unsigned_16) then |
| Lib_RE := RE_TC_U16; |
| |
| elsif U_Type = RTE (RE_Unsigned_32) then |
| Lib_RE := RE_TC_U32; |
| |
| elsif U_Type = RTE (RE_Unsigned_64) then |
| Lib_RE := RE_TC_U64; |
| |
| elsif Is_RTE (U_Type, RE_Unbounded_String) then |
| Lib_RE := RE_TC_String; |
| |
| -- Special DSA types |
| |
| elsif Is_RTE (U_Type, RE_Any_Container_Ptr) then |
| Lib_RE := RE_TC_A; |
| |
| -- Other (non-primitive) types |
| |
| else |
| declare |
| Decl : Entity_Id; |
| begin |
| Build_TypeCode_Function (Loc, U_Type, Decl, Fnam); |
| Append_To (Decls, Decl); |
| end; |
| end if; |
| |
| if Lib_RE /= RE_Null then |
| Fnam := RTE (Lib_RE); |
| end if; |
| end if; |
| |
| -- Call the function |
| |
| Expr := |
| Make_Function_Call (Loc, Name => New_Occurrence_Of (Fnam, Loc)); |
| |
| -- Allow Expr to be used as arg to Build_To_Any_Call immediately |
| |
| Set_Etype (Expr, RTE (RE_TypeCode)); |
| |
| return Expr; |
| end Build_TypeCode_Call; |
| |
| ----------------------------- |
| -- Build_TypeCode_Function -- |
| ----------------------------- |
| |
| procedure Build_TypeCode_Function |
| (Loc : Source_Ptr; |
| Typ : Entity_Id; |
| Decl : out Node_Id; |
| Fnam : out Entity_Id) |
| is |
| Spec : Node_Id; |
| Decls : constant List_Id := New_List; |
| Stms : constant List_Id := New_List; |
| |
| TCNam : constant Entity_Id := |
| Make_Helper_Function_Name (Loc, Typ, Name_TypeCode); |
| |
| Parameters : List_Id; |
| |
| procedure Add_String_Parameter |
| (S : String_Id; |
| Parameter_List : List_Id); |
| -- Add a literal for S to Parameters |
| |
| procedure Add_TypeCode_Parameter |
| (TC_Node : Node_Id; |
| Parameter_List : List_Id); |
| -- Add the typecode for Typ to Parameters |
| |
| procedure Add_Long_Parameter |
| (Expr_Node : Node_Id; |
| Parameter_List : List_Id); |
| -- Add a signed long integer expression to Parameters |
| |
| procedure Initialize_Parameter_List |
| (Name_String : String_Id; |
| Repo_Id_String : String_Id; |
| Parameter_List : out List_Id); |
| -- Return a list that contains the first two parameters |
| -- for a parameterized typecode: name and repository id. |
| |
| function Make_Constructed_TypeCode |
| (Kind : Entity_Id; |
| Parameters : List_Id) return Node_Id; |
| -- Call Build_Complex_TC with the given kind and parameters |
| |
| procedure Return_Constructed_TypeCode (Kind : Entity_Id); |
| -- Make a return statement that calls Build_Complex_TC with the |
| -- given typecode kind, and the constructed parameters list. |
| |
| procedure Return_Alias_TypeCode (Base_TypeCode : Node_Id); |
| -- Return a typecode that is a TC_Alias for the given typecode |
| |
| -------------------------- |
| -- Add_String_Parameter -- |
| -------------------------- |
| |
| procedure Add_String_Parameter |
| (S : String_Id; |
| Parameter_List : List_Id) |
| is |
| begin |
| Append_To (Parameter_List, |
| Make_Function_Call (Loc, |
| Name => New_Occurrence_Of (RTE (RE_TA_Std_String), Loc), |
| Parameter_Associations => New_List ( |
| Make_String_Literal (Loc, S)))); |
| end Add_String_Parameter; |
| |
| ---------------------------- |
| -- Add_TypeCode_Parameter -- |
| ---------------------------- |
| |
| procedure Add_TypeCode_Parameter |
| (TC_Node : Node_Id; |
| Parameter_List : List_Id) |
| is |
| begin |
| Append_To (Parameter_List, |
| Make_Function_Call (Loc, |
| Name => New_Occurrence_Of (RTE (RE_TA_TC), Loc), |
| Parameter_Associations => New_List (TC_Node))); |
| end Add_TypeCode_Parameter; |
| |
| ------------------------ |
| -- Add_Long_Parameter -- |
| ------------------------ |
| |
| procedure Add_Long_Parameter |
| (Expr_Node : Node_Id; |
| Parameter_List : List_Id) |
| is |
| begin |
| Append_To (Parameter_List, |
| Make_Function_Call (Loc, |
| Name => |
| New_Occurrence_Of (RTE (RE_TA_I32), Loc), |
| Parameter_Associations => New_List (Expr_Node))); |
| end Add_Long_Parameter; |
| |
| ------------------------------- |
| -- Initialize_Parameter_List -- |
| ------------------------------- |
| |
| procedure Initialize_Parameter_List |
| (Name_String : String_Id; |
| Repo_Id_String : String_Id; |
| Parameter_List : out List_Id) |
| is |
| begin |
| Parameter_List := New_List; |
| Add_String_Parameter (Name_String, Parameter_List); |
| Add_String_Parameter (Repo_Id_String, Parameter_List); |
| end Initialize_Parameter_List; |
| |
| --------------------------- |
| -- Return_Alias_TypeCode -- |
| --------------------------- |
| |
| procedure Return_Alias_TypeCode (Base_TypeCode : Node_Id) is |
| begin |
| Add_TypeCode_Parameter (Base_TypeCode, Parameters); |
| Return_Constructed_TypeCode (RTE (RE_Tk_Alias)); |
| end Return_Alias_TypeCode; |
| |
| ------------------------------- |
| -- Make_Constructed_TypeCode -- |
| ------------------------------- |
| |
| function Make_Constructed_TypeCode |
| (Kind : Entity_Id; |
| Parameters : List_Id) return Node_Id |
| is |
| Constructed_TC : constant Node_Id := |
| Make_Function_Call (Loc, |
| Name => |
| New_Occurrence_Of (RTE (RE_Build_Complex_TC), Loc), |
| Parameter_Associations => New_List ( |
| New_Occurrence_Of (Kind, Loc), |
| Make_Aggregate (Loc, |
| Expressions => Parameters))); |
| begin |
| Set_Etype (Constructed_TC, RTE (RE_TypeCode)); |
| return Constructed_TC; |
| end Make_Constructed_TypeCode; |
| |
| --------------------------------- |
| -- Return_Constructed_TypeCode -- |
| --------------------------------- |
| |
| procedure Return_Constructed_TypeCode (Kind : Entity_Id) is |
| begin |
| Append_To (Stms, |
| Make_Simple_Return_Statement (Loc, |
| Expression => |
| Make_Constructed_TypeCode (Kind, Parameters))); |
| end Return_Constructed_TypeCode; |
| |
| ------------------ |
| -- Record types -- |
| ------------------ |
| |
| procedure TC_Rec_Add_Process_Element |
| (Params : List_Id; |
| Any : Entity_Id; |
| Counter : in out Nat; |
| Rec : Entity_Id; |
| Field : Node_Id); |
| |
| procedure TC_Append_Record_Traversal is |
| new Append_Record_Traversal ( |
| Rec => Empty, |
| Add_Process_Element => TC_Rec_Add_Process_Element); |
| |
| -------------------------------- |
| -- TC_Rec_Add_Process_Element -- |
| -------------------------------- |
| |
| procedure TC_Rec_Add_Process_Element |
| (Params : List_Id; |
| Any : Entity_Id; |
| Counter : in out Nat; |
| Rec : Entity_Id; |
| Field : Node_Id) |
| is |
| pragma Unreferenced (Any, Counter, Rec); |
| |
| begin |
| if Nkind (Field) = N_Defining_Identifier then |
| |
| -- A regular component |
| |
| Add_TypeCode_Parameter |
| (Build_TypeCode_Call (Loc, Etype (Field), Decls), Params); |
| Get_Name_String (Chars (Field)); |
| Add_String_Parameter (String_From_Name_Buffer, Params); |
| |
| else |
| |
| -- A variant part |
| |
| Variant_Part : declare |
| Disc_Type : constant Entity_Id := Etype (Name (Field)); |
| |
| Is_Enum : constant Boolean := |
| Is_Enumeration_Type (Disc_Type); |
| |
| Union_TC_Params : List_Id; |
| |
| U_Name : constant Name_Id := |
| New_External_Name (Chars (Typ), 'V', -1); |
| |
| Name_Str : String_Id; |
| Struct_TC_Params : List_Id; |
| |
| Variant : Node_Id; |
| Choice : Node_Id; |
| Default : constant Node_Id := |
| Make_Integer_Literal (Loc, -1); |
| |
| Dummy_Counter : Nat := 0; |
| |
| Choice_Index : Int := 0; |
| -- Index of current choice in TypeCode, used to identify |
| -- it as the default choice if it is a "when others". |
| |
| procedure Add_Params_For_Variant_Components; |
| -- Add a struct TypeCode and a corresponding member name |
| -- to the union parameter list. |
| |
| -- Ordering of declarations is a complete mess in this |
| -- area, it is supposed to be types/variables, then |
| -- subprogram specs, then subprogram bodies ??? |
| |
| --------------------------------------- |
| -- Add_Params_For_Variant_Components -- |
| --------------------------------------- |
| |
| procedure Add_Params_For_Variant_Components is |
| S_Name : constant Name_Id := |
| New_External_Name (U_Name, 'S', -1); |
| |
| begin |
| Get_Name_String (S_Name); |
| Name_Str := String_From_Name_Buffer; |
| Initialize_Parameter_List |
| (Name_Str, Name_Str, Struct_TC_Params); |
| |
| -- Build struct parameters |
| |
| TC_Append_Record_Traversal (Struct_TC_Params, |
| Component_List (Variant), |
| Empty, |
| Dummy_Counter); |
| |
| Add_TypeCode_Parameter |
| (Make_Constructed_TypeCode |
| (RTE (RE_Tk_Struct), Struct_TC_Params), |
| Union_TC_Params); |
| |
| Add_String_Parameter (Name_Str, Union_TC_Params); |
| end Add_Params_For_Variant_Components; |
| |
| -- Start of processing for Variant_Part |
| |
| begin |
| Get_Name_String (U_Name); |
| Name_Str := String_From_Name_Buffer; |
| |
| Initialize_Parameter_List |
| (Name_Str, Name_Str, Union_TC_Params); |
| |
| -- Add union in enclosing parameter list |
| |
| Add_TypeCode_Parameter |
| (Make_Constructed_TypeCode |
| (RTE (RE_Tk_Union), Union_TC_Params), |
| Params); |
| |
| Add_String_Parameter (Name_Str, Params); |
| |
| -- Build union parameters |
| |
| Add_TypeCode_Parameter |
| (Build_TypeCode_Call (Loc, Disc_Type, Decls), |
| Union_TC_Params); |
| |
| Add_Long_Parameter (Default, Union_TC_Params); |
| |
| Variant := First_Non_Pragma (Variants (Field)); |
| while Present (Variant) loop |
| Choice := First (Discrete_Choices (Variant)); |
| while Present (Choice) loop |
| case Nkind (Choice) is |
| when N_Range => |
| declare |
| L : constant Uint := |
| Expr_Value (Low_Bound (Choice)); |
| H : constant Uint := |
| Expr_Value (High_Bound (Choice)); |
| J : Uint := L; |
| -- 3.8.1(8) guarantees that the bounds of |
| -- this range are static. |
| |
| Expr : Node_Id; |
| |
| begin |
| while J <= H loop |
| if Is_Enum then |
| Expr := Get_Enum_Lit_From_Pos |
| (Disc_Type, J, Loc); |
| else |
| Expr := |
| Make_Integer_Literal (Loc, J); |
| end if; |
| |
| Set_Etype (Expr, Disc_Type); |
| Append_To (Union_TC_Params, |
| Build_To_Any_Call (Loc, Expr, Decls)); |
| |
| Add_Params_For_Variant_Components; |
| J := J + Uint_1; |
| end loop; |
| |
| Choice_Index := |
| Choice_Index + UI_To_Int (H - L) + 1; |
| end; |
| |
| when N_Others_Choice => |
| |
| -- This variant has a default choice. We must |
| -- therefore set the default parameter to the |
| -- current choice index. This parameter is by |
| -- construction the 4th in Union_TC_Params. |
| |
| Replace |
| (Pick (Union_TC_Params, 4), |
| Make_Function_Call (Loc, |
| Name => |
| New_Occurrence_Of |
| (RTE (RE_TA_I32), Loc), |
| Parameter_Associations => |
| New_List ( |
| Make_Integer_Literal (Loc, |
| Intval => Choice_Index)))); |
| |
| -- Add a placeholder member label for the |
| -- default case, which must have the |
| -- discriminant type. |
| |
| declare |
| Exp : constant Node_Id := |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Occurrence_Of |
| (Disc_Type, Loc), |
| Attribute_Name => Name_First); |
| begin |
| Set_Etype (Exp, Disc_Type); |
| Append_To (Union_TC_Params, |
| Build_To_Any_Call (Loc, Exp, Decls)); |
| end; |
| |
| Add_Params_For_Variant_Components; |
| Choice_Index := Choice_Index + 1; |
| |
| -- Case of an explicit choice |
| |
| when others => |
| declare |
| Exp : constant Node_Id := |
| New_Copy_Tree (Choice); |
| begin |
| Append_To (Union_TC_Params, |
| Build_To_Any_Call (Loc, Exp, Decls)); |
| end; |
| |
| Add_Params_For_Variant_Components; |
| Choice_Index := Choice_Index + 1; |
| end case; |
| |
| Next (Choice); |
| end loop; |
| |
| Next_Non_Pragma (Variant); |
| end loop; |
| end Variant_Part; |
| end if; |
| end TC_Rec_Add_Process_Element; |
| |
| Type_Name_Str : String_Id; |
| Type_Repo_Id_Str : String_Id; |
| |
| -- Start of processing for Build_TypeCode_Function |
| |
| begin |
| -- For a derived type, we can't go past the base type (to the |
| -- parent type) here, because that would cause the attribute's |
| -- formal parameter to have the wrong type; hence the Base_Type |
| -- check here. |
| |
| if Is_Itype (Typ) and then Typ /= Base_Type (Typ) then |
| Build_TypeCode_Function |
| (Loc => Loc, |
| Typ => Etype (Typ), |
| Decl => Decl, |
| Fnam => Fnam); |
| return; |
| end if; |
| |
| Fnam := TCNam; |
| |
| Spec := |
| Make_Function_Specification (Loc, |
| Defining_Unit_Name => Fnam, |
| Parameter_Specifications => Empty_List, |
| Result_Definition => |
| New_Occurrence_Of (RTE (RE_TypeCode), Loc)); |
| |
| Build_Name_And_Repository_Id (Typ, |
| Name_Str => Type_Name_Str, Repo_Id_Str => Type_Repo_Id_Str); |
| |
| Initialize_Parameter_List |
| (Type_Name_Str, Type_Repo_Id_Str, Parameters); |
| |
| if Has_Stream_Attribute_Definition |
| (Typ, TSS_Stream_Output, At_Any_Place => True) |
| or else |
| Has_Stream_Attribute_Definition |
| (Typ, TSS_Stream_Write, At_Any_Place => True) |
| then |
| -- If user-defined stream attributes are specified for this |
| -- type, use them and transmit data as an opaque sequence of |
| -- stream elements. |
| |
| Return_Alias_TypeCode |
| (New_Occurrence_Of (RTE (RE_TC_Opaque), Loc)); |
| |
| elsif Is_Derived_Type (Typ) and then not Is_Tagged_Type (Typ) then |
| Return_Alias_TypeCode ( |
| Build_TypeCode_Call (Loc, Etype (Typ), Decls)); |
| |
| elsif Is_Integer_Type (Typ) or else Is_Unsigned_Type (Typ) then |
| Return_Alias_TypeCode ( |
| Build_TypeCode_Call (Loc, |
| Find_Numeric_Representation (Typ), Decls)); |
| |
| elsif Is_Record_Type (Typ) and then not Is_Tagged_Type (Typ) then |
| |
| -- Record typecodes are encoded as follows: |
| -- -- TC_STRUCT |
| -- | |
| -- | [Name] |
| -- | [Repository Id] |
| -- |
| -- Then for each discriminant: |
| -- |
| -- | [Discriminant Type Code] |
| -- | [Discriminant Name] |
| -- | ... |
| -- |
| -- Then for each component: |
| -- |
| -- | [Component Type Code] |
| -- | [Component Name] |
| -- | ... |
| -- |
| -- Variants components type codes are encoded as follows: |
| -- -- TC_UNION |
| -- | |
| -- | [Name] |
| -- | [Repository Id] |
| -- | [Discriminant Type Code] |
| -- | [Index of Default Variant Part or -1 for no default] |
| -- |
| -- Then for each Variant Part : |
| -- |
| -- | [VP Label] |
| -- | |
| -- | -- TC_STRUCT |
| -- | | [Variant Part Name] |
| -- | | [Variant Part Repository Id] |
| -- | | |
| -- | Then for each VP component: |
| -- | | [VP component Typecode] |
| -- | | [VP component Name] |
| -- | | ... |
| -- | -- |
| -- | |
| -- | [VP Name] |
| |
| if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then |
| Return_Alias_TypeCode |
| (Build_TypeCode_Call (Loc, Etype (Typ), Decls)); |
| |
| else |
| declare |
| Disc : Entity_Id := Empty; |
| Rdef : constant Node_Id := |
| Type_Definition (Declaration_Node (Typ)); |
| Dummy_Counter : Int := 0; |
| |
| begin |
| -- Construct the discriminants typecodes |
| |
| if Has_Discriminants (Typ) then |
| Disc := First_Discriminant (Typ); |
| end if; |
| |
| while Present (Disc) loop |
| Add_TypeCode_Parameter ( |
| Build_TypeCode_Call (Loc, Etype (Disc), Decls), |
| Parameters); |
| Get_Name_String (Chars (Disc)); |
| Add_String_Parameter ( |
| String_From_Name_Buffer, |
| Parameters); |
| Next_Discriminant (Disc); |
| end loop; |
| |
| -- then the components typecodes |
| |
| TC_Append_Record_Traversal |
| (Parameters, Component_List (Rdef), |
| Empty, Dummy_Counter); |
| Return_Constructed_TypeCode (RTE (RE_Tk_Struct)); |
| end; |
| end if; |
| |
| elsif Is_Array_Type (Typ) then |
| declare |
| Ndim : constant Pos := Number_Dimensions (Typ); |
| Inner_TypeCode : Node_Id; |
| Constrained : constant Boolean := Is_Constrained (Typ); |
| Indx : Node_Id := First_Index (Typ); |
| |
| begin |
| Inner_TypeCode := |
| Build_TypeCode_Call (Loc, Component_Type (Typ), Decls); |
| |
| for J in 1 .. Ndim loop |
| if Constrained then |
| Inner_TypeCode := Make_Constructed_TypeCode |
| (RTE (RE_Tk_Array), New_List ( |
| Build_To_Any_Call (Loc, |
| OK_Convert_To (RTE (RE_Unsigned_32), |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Occurrence_Of (Typ, Loc), |
| Attribute_Name => Name_Length, |
| Expressions => New_List ( |
| Make_Integer_Literal (Loc, |
| Intval => Ndim - J + 1)))), |
| Decls), |
| Build_To_Any_Call (Loc, Inner_TypeCode, Decls))); |
| |
| else |
| -- Unconstrained case: add low bound for each |
| -- dimension. |
| |
| Add_TypeCode_Parameter |
| (Build_TypeCode_Call (Loc, Etype (Indx), Decls), |
| Parameters); |
| Get_Name_String (New_External_Name ('L', J)); |
| Add_String_Parameter ( |
| String_From_Name_Buffer, |
| Parameters); |
| Next_Index (Indx); |
| |
| Inner_TypeCode := Make_Constructed_TypeCode |
| (RTE (RE_Tk_Sequence), New_List ( |
| Build_To_Any_Call (Loc, |
| OK_Convert_To (RTE (RE_Unsigned_32), |
| Make_Integer_Literal (Loc, 0)), |
| Decls), |
| Build_To_Any_Call (Loc, Inner_TypeCode, Decls))); |
| end if; |
| end loop; |
| |
| if Constrained then |
| Return_Alias_TypeCode (Inner_TypeCode); |
| else |
| Add_TypeCode_Parameter (Inner_TypeCode, Parameters); |
| Start_String; |
| Store_String_Char ('V'); |
| Add_String_Parameter (End_String, Parameters); |
| Return_Constructed_TypeCode (RTE (RE_Tk_Struct)); |
| end if; |
| end; |
| |
| else |
| -- Default: type is represented as an opaque sequence of bytes |
| |
| Return_Alias_TypeCode |
| (New_Occurrence_Of (RTE (RE_TC_Opaque), Loc)); |
| end if; |
| |
| Decl := |
| Make_Subprogram_Body (Loc, |
| Specification => Spec, |
| Declarations => Decls, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => Stms)); |
| end Build_TypeCode_Function; |
| |
| --------------------------------- |
| -- Find_Numeric_Representation -- |
| --------------------------------- |
| |
| function Find_Numeric_Representation |
| (Typ : Entity_Id) return Entity_Id |
| is |
| FST : constant Entity_Id := First_Subtype (Typ); |
| P_Size : constant Uint := Esize (FST); |
| |
| begin |
| -- Special case: for Stream_Element_Offset and Storage_Offset, |
| -- always force transmission as a 64-bit value. |
| |
| if Is_RTE (FST, RE_Stream_Element_Offset) |
| or else |
| Is_RTE (FST, RE_Storage_Offset) |
| then |
| return RTE (RE_Unsigned_64); |
| end if; |
| |
| if Is_Unsigned_Type (Typ) then |
| if P_Size <= 8 then |
| return RTE (RE_Unsigned_8); |
| |
| elsif P_Size <= 16 then |
| return RTE (RE_Unsigned_16); |
| |
| elsif P_Size <= 32 then |
| return RTE (RE_Unsigned_32); |
| |
| else |
| return RTE (RE_Unsigned_64); |
| end if; |
| |
| elsif Is_Integer_Type (Typ) then |
| if P_Size <= 8 then |
| return RTE (RE_Integer_8); |
| |
| elsif P_Size <= Standard_Short_Integer_Size then |
| return RTE (RE_Integer_16); |
| |
| elsif P_Size <= Standard_Integer_Size then |
| return RTE (RE_Integer_32); |
| |
| else |
| return RTE (RE_Integer_64); |
| end if; |
| |
| elsif Is_Floating_Point_Type (Typ) then |
| if P_Size <= Standard_Short_Float_Size then |
| return Standard_Short_Float; |
| |
| elsif P_Size <= Standard_Float_Size then |
| return Standard_Float; |
| |
| elsif P_Size <= Standard_Long_Float_Size then |
| return Standard_Long_Float; |
| |
| else |
| return Standard_Long_Long_Float; |
| end if; |
| |
| else |
| raise Program_Error; |
| end if; |
| |
| -- What about fixed point types and numeric types with a biased |
| -- representation??? |
| |
| end Find_Numeric_Representation; |
| |
| --------------------------------- |
| -- Is_Generic_Actual_Subtype -- |
| --------------------------------- |
| |
| function Is_Generic_Actual_Subtype (Typ : Entity_Id) return Boolean is |
| begin |
| if Is_Itype (Typ) |
| and then Present (Associated_Node_For_Itype (Typ)) |
| then |
| declare |
| N : constant Node_Id := Associated_Node_For_Itype (Typ); |
| begin |
| if Nkind (N) = N_Subtype_Declaration |
| and then Nkind (Parent (N)) = N_Package_Specification |
| and then Is_Generic_Instance (Scope_Of_Spec (Parent (N))) |
| then |
| return True; |
| end if; |
| end; |
| end if; |
| |
| return False; |
| end Is_Generic_Actual_Subtype; |
| |
| --------------------------- |
| -- Append_Array_Traversal -- |
| --------------------------- |
| |
| procedure Append_Array_Traversal |
| (Stmts : List_Id; |
| Any : Entity_Id; |
| Counter : Entity_Id := Empty; |
| Depth : Pos := 1) |
| is |
| Loc : constant Source_Ptr := Sloc (Subprogram); |
| Typ : constant Entity_Id := Etype (Arry); |
| Constrained : constant Boolean := Is_Constrained (Typ); |
| Ndim : constant Pos := Number_Dimensions (Typ); |
| |
| Inner_Any, Inner_Counter : Entity_Id; |
| |
| Loop_Stm : Node_Id; |
| Inner_Stmts : constant List_Id := New_List; |
| |
| begin |
| if Depth > Ndim then |
| |
| -- Processing for one element of an array |
| |
| declare |
| Element_Expr : constant Node_Id := |
| Make_Indexed_Component (Loc, |
| New_Occurrence_Of (Arry, Loc), |
| Indexes); |
| begin |
| Set_Etype (Element_Expr, Component_Type (Typ)); |
| Add_Process_Element (Stmts, |
| Any => Any, |
| Counter => Counter, |
| Datum => Element_Expr); |
| end; |
| |
| return; |
| end if; |
| |
| Append_To (Indexes, |
| Make_Identifier (Loc, New_External_Name ('L', Depth))); |
| |
| if not Constrained or else Depth > 1 then |
| Inner_Any := Make_Defining_Identifier (Loc, |
| New_External_Name ('A', Depth)); |
| Set_Etype (Inner_Any, RTE (RE_Any)); |
| else |
| Inner_Any := Empty; |
| end if; |
| |
| if Present (Counter) then |
| Inner_Counter := Make_Defining_Identifier (Loc, |
| New_External_Name ('J', Depth)); |
| else |
| Inner_Counter := Empty; |
| end if; |
| |
| declare |
| Loop_Any : Node_Id := Inner_Any; |
| |
| begin |
| -- For the first dimension of a constrained array, we add |
| -- elements directly in the corresponding Any; there is no |
| -- intervening inner Any. |
| |
| if No (Loop_Any) then |
| Loop_Any := Any; |
| end if; |
| |
| Append_Array_Traversal (Inner_Stmts, |
| Any => Loop_Any, |
| Counter => Inner_Counter, |
| Depth => Depth + 1); |
| end; |
| |
| Loop_Stm := |
| Make_Implicit_Loop_Statement (Subprogram, |
| Iteration_Scheme => |
| Make_Iteration_Scheme (Loc, |
| Loop_Parameter_Specification => |
| Make_Loop_Parameter_Specification (Loc, |
| Defining_Identifier => |
| Make_Defining_Identifier (Loc, |
| Chars => New_External_Name ('L', Depth)), |
| |
| Discrete_Subtype_Definition => |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Occurrence_Of (Arry, Loc), |
| Attribute_Name => Name_Range, |
| |
| Expressions => New_List ( |
| Make_Integer_Literal (Loc, Depth))))), |
| Statements => Inner_Stmts); |
| |
| declare |
| Decls : constant List_Id := New_List; |
| Dimen_Stmts : constant List_Id := New_List; |
| Length_Node : Node_Id; |
| |
| Inner_Any_TypeCode : constant Entity_Id := |
| Make_Defining_Identifier (Loc, |
| New_External_Name ('T', Depth)); |
| |
| Inner_Any_TypeCode_Expr : Node_Id; |
| |
| begin |
| if Depth = 1 then |
| if Constrained then |
| Inner_Any_TypeCode_Expr := |
| Make_Function_Call (Loc, |
| Name => New_Occurrence_Of (RTE (RE_Get_TC), Loc), |
| Parameter_Associations => New_List ( |
| New_Occurrence_Of (Any, Loc))); |
| |
| else |
| Inner_Any_TypeCode_Expr := |
| Make_Function_Call (Loc, |
| Name => |
| New_Occurrence_Of (RTE (RE_Any_Member_Type), Loc), |
| Parameter_Associations => New_List ( |
| New_Occurrence_Of (Any, Loc), |
| Make_Integer_Literal (Loc, Ndim))); |
| end if; |
| |
| else |
| Inner_Any_TypeCode_Expr := |
| Make_Function_Call (Loc, |
| Name => New_Occurrence_Of (RTE (RE_Content_Type), Loc), |
| Parameter_Associations => New_List ( |
| Make_Identifier (Loc, |
| Chars => New_External_Name ('T', Depth - 1)))); |
| end if; |
| |
| Append_To (Decls, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Inner_Any_TypeCode, |
| Constant_Present => True, |
| Object_Definition => New_Occurrence_Of ( |
| RTE (RE_TypeCode), Loc), |
| Expression => Inner_Any_TypeCode_Expr)); |
| |
| if Present (Inner_Any) then |
| Append_To (Decls, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Inner_Any, |
| Object_Definition => |
| New_Occurrence_Of (RTE (RE_Any), Loc), |
| Expression => |
| Make_Function_Call (Loc, |
| Name => |
| New_Occurrence_Of ( |
| RTE (RE_Create_Any), Loc), |
| Parameter_Associations => New_List ( |
| New_Occurrence_Of (Inner_Any_TypeCode, Loc))))); |
| end if; |
| |
| if Present (Inner_Counter) then |
| Append_To (Decls, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Inner_Counter, |
| Object_Definition => |
| New_Occurrence_Of (RTE (RE_Unsigned_32), Loc), |
| Expression => |
| Make_Integer_Literal (Loc, 0))); |
| end if; |
| |
| if not Constrained then |
| Length_Node := Make_Attribute_Reference (Loc, |
| Prefix => New_Occurrence_Of (Arry, Loc), |
| Attribute_Name => Name_Length, |
| Expressions => |
| New_List (Make_Integer_Literal (Loc, Depth))); |
| Set_Etype (Length_Node, RTE (RE_Unsigned_32)); |
| |
| Add_Process_Element (Dimen_Stmts, |
| Datum => Length_Node, |
| Any => Inner_Any, |
| Counter => Inner_Counter); |
| end if; |
| |
| -- Loop_Stm does appropriate processing for each element |
| -- of Inner_Any. |
| |
| Append_To (Dimen_Stmts, Loop_Stm); |
| |
| -- Link outer and inner any |
| |
| if Present (Inner_Any) then |
| Add_Process_Element (Dimen_Stmts, |
| Any => Any, |
| Counter => Counter, |
| Datum => New_Occurrence_Of (Inner_Any, Loc)); |
| end if; |
| |
| Append_To (Stmts, |
| Make_Block_Statement (Loc, |
| Declarations => |
| Decls, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => Dimen_Stmts))); |
| end; |
| end Append_Array_Traversal; |
| |
| ------------------------------- |
| -- Make_Helper_Function_Name -- |
| ------------------------------- |
| |
| function Make_Helper_Function_Name |
| (Loc : Source_Ptr; |
| Typ : Entity_Id; |
| Nam : Name_Id) return Entity_Id |
| is |
| begin |
| declare |
| Serial : Nat := 0; |
| -- For tagged types that aren't frozen yet, generate the helper |
| -- under its canonical name so that it matches the primitive |
| -- spec. For all other cases, we use a serialized name so that |
| -- multiple generations of the same procedure do not clash. |
| |
| begin |
| if Is_Tagged_Type (Typ) and then not Is_Frozen (Typ) then |
| null; |
| else |
| Serial := Increment_Serial_Number; |
| end if; |
| |
| -- Use prefixed underscore to avoid potential clash with user |
| -- identifier (we use attribute names for Nam). |
| |
| return |
| Make_Defining_Identifier (Loc, |
| Chars => |
| New_External_Name |
| (Related_Id => Nam, |
| Suffix => ' ', |
| Suffix_Index => Serial, |
| Prefix => '_')); |
| end; |
| end Make_Helper_Function_Name; |
| end Helpers; |
| |
| ----------------------------------- |
| -- Reserve_NamingContext_Methods -- |
| ----------------------------------- |
| |
| procedure Reserve_NamingContext_Methods is |
| Str_Resolve : constant String := "resolve"; |
| begin |
| Name_Buffer (1 .. Str_Resolve'Length) := Str_Resolve; |
| Name_Len := Str_Resolve'Length; |
| Overload_Counter_Table.Set (Name_Find, 1); |
| end Reserve_NamingContext_Methods; |
| |
| ----------------------- |
| -- RPC_Receiver_Decl -- |
| ----------------------- |
| |
| function RPC_Receiver_Decl (RACW_Type : Entity_Id) return Node_Id is |
| Loc : constant Source_Ptr := Sloc (RACW_Type); |
| begin |
| return |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Make_Temporary (Loc, 'R'), |
| Aliased_Present => True, |
| Object_Definition => New_Occurrence_Of (RTE (RE_Servant), Loc)); |
| end RPC_Receiver_Decl; |
| |
| end PolyORB_Support; |
| |
| ------------------------------- |
| -- RACW_Type_Is_Asynchronous -- |
| ------------------------------- |
| |
| procedure RACW_Type_Is_Asynchronous (RACW_Type : Entity_Id) is |
| Asynchronous_Flag : constant Entity_Id := |
| Asynchronous_Flags_Table.Get (RACW_Type); |
| begin |
| Replace (Expression (Parent (Asynchronous_Flag)), |
| New_Occurrence_Of (Standard_True, Sloc (Asynchronous_Flag))); |
| end RACW_Type_Is_Asynchronous; |
| |
| ------------------------- |
| -- RCI_Package_Locator -- |
| ------------------------- |
| |
| function RCI_Package_Locator |
| (Loc : Source_Ptr; |
| Package_Spec : Node_Id) return Node_Id |
| is |
| Inst : Node_Id; |
| Pkg_Name : constant String_Id := |
| Fully_Qualified_Name_String |
| (Defining_Entity (Package_Spec), Append_NUL => False); |
| |
| begin |
| Inst := |
| Make_Package_Instantiation (Loc, |
| Defining_Unit_Name => Make_Temporary (Loc, 'R'), |
| |
| Name => |
| New_Occurrence_Of (RTE (RE_RCI_Locator), Loc), |
| |
| Generic_Associations => New_List ( |
| Make_Generic_Association (Loc, |
| Selector_Name => |
| Make_Identifier (Loc, Name_RCI_Name), |
| Explicit_Generic_Actual_Parameter => |
| Make_String_Literal (Loc, |
| Strval => Pkg_Name)), |
| |
| Make_Generic_Association (Loc, |
| Selector_Name => |
| Make_Identifier (Loc, Name_Version), |
| Explicit_Generic_Actual_Parameter => |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| New_Occurrence_Of (Defining_Entity (Package_Spec), Loc), |
| Attribute_Name => |
| Name_Version)))); |
| |
| RCI_Locator_Table.Set |
| (Defining_Unit_Name (Package_Spec), |
| Defining_Unit_Name (Inst)); |
| return Inst; |
| end RCI_Package_Locator; |
| |
| ----------------------------------------------- |
| -- Remote_Types_Tagged_Full_View_Encountered -- |
| ----------------------------------------------- |
| |
| procedure Remote_Types_Tagged_Full_View_Encountered |
| (Full_View : Entity_Id) |
| is |
| Stub_Elements : constant Stub_Structure := |
| Stubs_Table.Get (Full_View); |
| |
| begin |
| -- For an RACW encountered before the freeze point of its designated |
| -- type, the stub type is generated at the point of the RACW declaration |
| -- but the primitives are generated only once the designated type is |
| -- frozen. That freeze can occur in another scope, for example when the |
| -- RACW is declared in a nested package. In that case we need to |
| -- reestablish the stub type's scope prior to generating its primitive |
| -- operations. |
| |
| if Stub_Elements /= Empty_Stub_Structure then |
| declare |
| Saved_Scope : constant Entity_Id := Current_Scope; |
| Stubs_Scope : constant Entity_Id := |
| Scope (Stub_Elements.Stub_Type); |
| |
| begin |
| if Current_Scope /= Stubs_Scope then |
| Push_Scope (Stubs_Scope); |
| end if; |
| |
| Add_RACW_Primitive_Declarations_And_Bodies |
| (Full_View, |
| Stub_Elements.RPC_Receiver_Decl, |
| Stub_Elements.Body_Decls); |
| |
| if Current_Scope /= Saved_Scope then |
| Pop_Scope; |
| end if; |
| end; |
| end if; |
| end Remote_Types_Tagged_Full_View_Encountered; |
| |
| ------------------- |
| -- Scope_Of_Spec -- |
| ------------------- |
| |
| function Scope_Of_Spec (Spec : Node_Id) return Entity_Id is |
| Unit_Name : Node_Id; |
| |
| begin |
| Unit_Name := Defining_Unit_Name (Spec); |
| while Nkind (Unit_Name) /= N_Defining_Identifier loop |
| Unit_Name := Defining_Identifier (Unit_Name); |
| end loop; |
| |
| return Unit_Name; |
| end Scope_Of_Spec; |
| |
| ---------------------- |
| -- Set_Renaming_TSS -- |
| ---------------------- |
| |
| procedure Set_Renaming_TSS |
| (Typ : Entity_Id; |
| Nam : Entity_Id; |
| TSS_Nam : TSS_Name_Type) |
| is |
| Loc : constant Source_Ptr := Sloc (Nam); |
| Spec : constant Node_Id := Parent (Nam); |
| |
| TSS_Node : constant Node_Id := |
| Make_Subprogram_Renaming_Declaration (Loc, |
| Specification => |
| Copy_Specification (Loc, |
| Spec => Spec, |
| New_Name => Make_TSS_Name (Typ, TSS_Nam)), |
| Name => New_Occurrence_Of (Nam, Loc)); |
| |
| Snam : constant Entity_Id := |
| Defining_Unit_Name (Specification (TSS_Node)); |
| |
| begin |
| if Nkind (Spec) = N_Function_Specification then |
| Mutate_Ekind (Snam, E_Function); |
| Set_Etype (Snam, Entity (Result_Definition (Spec))); |
| else |
| Mutate_Ekind (Snam, E_Procedure); |
| Set_Etype (Snam, Standard_Void_Type); |
| end if; |
| |
| Set_TSS (Typ, Snam); |
| end Set_Renaming_TSS; |
| |
| ---------------------------------------------- |
| -- Specific_Add_Obj_RPC_Receiver_Completion -- |
| ---------------------------------------------- |
| |
| procedure Specific_Add_Obj_RPC_Receiver_Completion |
| (Loc : Source_Ptr; |
| Decls : List_Id; |
| RPC_Receiver : Entity_Id; |
| Stub_Elements : Stub_Structure) |
| is |
| begin |
| case Get_PCS_Name is |
| when Name_PolyORB_DSA => |
| PolyORB_Support.Add_Obj_RPC_Receiver_Completion |
| (Loc, Decls, RPC_Receiver, Stub_Elements); |
| |
| when others => |
| GARLIC_Support.Add_Obj_RPC_Receiver_Completion |
| (Loc, Decls, RPC_Receiver, Stub_Elements); |
| end case; |
| end Specific_Add_Obj_RPC_Receiver_Completion; |
| |
| -------------------------------- |
| -- Specific_Add_RACW_Features -- |
| -------------------------------- |
| |
| procedure Specific_Add_RACW_Features |
| (RACW_Type : Entity_Id; |
| Desig : Entity_Id; |
| Stub_Type : Entity_Id; |
| Stub_Type_Access : Entity_Id; |
| RPC_Receiver_Decl : Node_Id; |
| Body_Decls : List_Id) |
| is |
| begin |
| case Get_PCS_Name is |
| when Name_PolyORB_DSA => |
| PolyORB_Support.Add_RACW_Features |
| (RACW_Type, |
| Desig, |
| Stub_Type, |
| Stub_Type_Access, |
| RPC_Receiver_Decl, |
| Body_Decls); |
| |
| when others => |
| GARLIC_Support.Add_RACW_Features |
| (RACW_Type, |
| Stub_Type, |
| Stub_Type_Access, |
| RPC_Receiver_Decl, |
| Body_Decls); |
| end case; |
| end Specific_Add_RACW_Features; |
| |
| -------------------------------- |
| -- Specific_Add_RAST_Features -- |
| -------------------------------- |
| |
| procedure Specific_Add_RAST_Features |
| (Vis_Decl : Node_Id; |
| RAS_Type : Entity_Id) |
| is |
| begin |
| case Get_PCS_Name is |
| when Name_PolyORB_DSA => |
| PolyORB_Support.Add_RAST_Features (Vis_Decl, RAS_Type); |
| |
| when others => |
| GARLIC_Support.Add_RAST_Features (Vis_Decl, RAS_Type); |
| end case; |
| end Specific_Add_RAST_Features; |
| |
| -------------------------------------------------- |
| -- Specific_Add_Receiving_Stubs_To_Declarations -- |
| -------------------------------------------------- |
| |
| procedure Specific_Add_Receiving_Stubs_To_Declarations |
| (Pkg_Spec : Node_Id; |
| Decls : List_Id; |
| Stmts : List_Id) |
| is |
| begin |
| case Get_PCS_Name is |
| when Name_PolyORB_DSA => |
| PolyORB_Support.Add_Receiving_Stubs_To_Declarations |
| (Pkg_Spec, Decls, Stmts); |
| |
| when others => |
| GARLIC_Support.Add_Receiving_Stubs_To_Declarations |
| (Pkg_Spec, Decls, Stmts); |
| end case; |
| end Specific_Add_Receiving_Stubs_To_Declarations; |
| |
| ------------------------------------------ |
| -- Specific_Build_General_Calling_Stubs -- |
| ------------------------------------------ |
| |
| procedure Specific_Build_General_Calling_Stubs |
| (Decls : List_Id; |
| Statements : List_Id; |
| Target : RPC_Target; |
| Subprogram_Id : Node_Id; |
| Asynchronous : Node_Id := Empty; |
| Is_Known_Asynchronous : Boolean := False; |
| Is_Known_Non_Asynchronous : Boolean := False; |
| Is_Function : Boolean; |
| Spec : Node_Id; |
| Stub_Type : Entity_Id := Empty; |
| RACW_Type : Entity_Id := Empty; |
| Nod : Node_Id) |
| is |
| begin |
| case Get_PCS_Name is |
| when Name_PolyORB_DSA => |
| PolyORB_Support.Build_General_Calling_Stubs |
| (Decls, |
| Statements, |
| Target.Object, |
| Subprogram_Id, |
| Asynchronous, |
| Is_Known_Asynchronous, |
| Is_Known_Non_Asynchronous, |
| Is_Function, |
| Spec, |
| Stub_Type, |
| RACW_Type, |
| Nod); |
| |
| when others => |
| GARLIC_Support.Build_General_Calling_Stubs |
| (Decls, |
| Statements, |
| Target.Partition, |
| Target.RPC_Receiver, |
| Subprogram_Id, |
| Asynchronous, |
| Is_Known_Asynchronous, |
| Is_Known_Non_Asynchronous, |
| Is_Function, |
| Spec, |
| Stub_Type, |
| RACW_Type, |
| Nod); |
| end case; |
| end Specific_Build_General_Calling_Stubs; |
| |
| -------------------------------------- |
| -- Specific_Build_RPC_Receiver_Body -- |
| -------------------------------------- |
| |
| procedure Specific_Build_RPC_Receiver_Body |
| (RPC_Receiver : Entity_Id; |
| Request : out Entity_Id; |
| Subp_Id : out Entity_Id; |
| Subp_Index : out Entity_Id; |
| Stmts : out List_Id; |
| Decl : out Node_Id) |
| is |
| begin |
| case Get_PCS_Name is |
| when Name_PolyORB_DSA => |
| PolyORB_Support.Build_RPC_Receiver_Body |
| (RPC_Receiver, |
| Request, |
| Subp_Id, |
| Subp_Index, |
| Stmts, |
| Decl); |
| |
| when others => |
| GARLIC_Support.Build_RPC_Receiver_Body |
| (RPC_Receiver, |
| Request, |
| Subp_Id, |
| Subp_Index, |
| Stmts, |
| Decl); |
| end case; |
| end Specific_Build_RPC_Receiver_Body; |
| |
| -------------------------------- |
| -- Specific_Build_Stub_Target -- |
| -------------------------------- |
| |
| function Specific_Build_Stub_Target |
| (Loc : Source_Ptr; |
| Decls : List_Id; |
| RCI_Locator : Entity_Id; |
| Controlling_Parameter : Entity_Id) return RPC_Target |
| is |
| begin |
| case Get_PCS_Name is |
| when Name_PolyORB_DSA => |
| return |
| PolyORB_Support.Build_Stub_Target |
| (Loc, Decls, RCI_Locator, Controlling_Parameter); |
| |
| when others => |
| return |
| GARLIC_Support.Build_Stub_Target |
| (Loc, Decls, RCI_Locator, Controlling_Parameter); |
| end case; |
| end Specific_Build_Stub_Target; |
| |
| -------------------------------- |
| -- Specific_RPC_Receiver_Decl -- |
| -------------------------------- |
| |
| function Specific_RPC_Receiver_Decl |
| (RACW_Type : Entity_Id) return Node_Id |
| is |
| begin |
| case Get_PCS_Name is |
| when Name_PolyORB_DSA => |
| return PolyORB_Support.RPC_Receiver_Decl (RACW_Type); |
| |
| when others => |
| return GARLIC_Support.RPC_Receiver_Decl (RACW_Type); |
| end case; |
| end Specific_RPC_Receiver_Decl; |
| |
| ----------------------------------------------- |
| -- Specific_Build_Subprogram_Receiving_Stubs -- |
| ----------------------------------------------- |
| |
| function Specific_Build_Subprogram_Receiving_Stubs |
| (Vis_Decl : Node_Id; |
| Asynchronous : Boolean; |
| Dynamically_Asynchronous : Boolean := False; |
| Stub_Type : Entity_Id := Empty; |
| RACW_Type : Entity_Id := Empty; |
| Parent_Primitive : Entity_Id := Empty) return Node_Id |
| is |
| begin |
| case Get_PCS_Name is |
| when Name_PolyORB_DSA => |
| return |
| PolyORB_Support.Build_Subprogram_Receiving_Stubs |
| (Vis_Decl, |
| Asynchronous, |
| Dynamically_Asynchronous, |
| Stub_Type, |
| RACW_Type, |
| Parent_Primitive); |
| |
| when others => |
| return |
| GARLIC_Support.Build_Subprogram_Receiving_Stubs |
| (Vis_Decl, |
| Asynchronous, |
| Dynamically_Asynchronous, |
| Stub_Type, |
| RACW_Type, |
| Parent_Primitive); |
| end case; |
| end Specific_Build_Subprogram_Receiving_Stubs; |
| |
| ------------------------------- |
| -- Transmit_As_Unconstrained -- |
| ------------------------------- |
| |
| function Transmit_As_Unconstrained (Typ : Entity_Id) return Boolean is |
| begin |
| return |
| not (Is_Elementary_Type (Typ) or else Is_Constrained (Typ)) |
| or else (Is_Access_Type (Typ) and then Can_Never_Be_Null (Typ)); |
| end Transmit_As_Unconstrained; |
| |
| -------------------------- |
| -- Underlying_RACW_Type -- |
| -------------------------- |
| |
| function Underlying_RACW_Type (RAS_Typ : Entity_Id) return Entity_Id is |
| Record_Type : Entity_Id; |
| |
| begin |
| if Ekind (RAS_Typ) = E_Record_Type then |
| Record_Type := RAS_Typ; |
| else |
| pragma Assert (Present (Equivalent_Type (RAS_Typ))); |
| Record_Type := Equivalent_Type (RAS_Typ); |
| end if; |
| |
| return |
| Etype (Subtype_Indication |
| (Component_Definition |
| (First (Component_Items |
| (Component_List |
| (Type_Definition |
| (Declaration_Node (Record_Type)))))))); |
| end Underlying_RACW_Type; |
| |
| end Exp_Dist; |