Google Git
Sign in
llvm / llvm-archive / b74e25f9042d5657e8f400dd820eba426827f1dd / . / llvm-gcc-4.2 / gcc / ada / exp_dist.adb
blob: 4fa42b6e7d547dac06abda8a35724c708bf7ca1f [file] [log] [blame]
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- E X P_ D I S T --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2006, 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 2, 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 COPYING. If not, write --
-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
-- Boston, MA 02110-1301, USA. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Atree; use Atree;
with Einfo; use Einfo;
with Elists; use Elists;
with Exp_Strm; use Exp_Strm;
with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
with GNAT.HTable; use GNAT.HTable;
with Lib; use Lib;
with Namet; use Namet;
with Nlists; use Nlists;
with Nmake; use Nmake;
with Opt; use Opt;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Ch3; use Sem_Ch3;
with Sem_Ch8; use Sem_Ch8;
with Sem_Dist; use Sem_Dist;
with Sem_Eval; use Sem_Eval;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Snames; use Snames;
with Stand; use Stand;
with Stringt; use Stringt;
with Tbuild; use Tbuild;
with Ttypes; use Ttypes;
with Uintp; use Uintp;
package body Exp_Dist is
-- The following model has been used to implement distributed objects:
-- given a designated type D and a RACW type R, then a record of the
-- form:
-- type Stub is tagged record
-- [...declaration similar to s-parint.ads RACW_Stub_Type...]
-- end record;
-- is built. This type has two properties:
-- 1) Since it has the same structure than RACW_Stub_Type, it can be
-- converted to and from this type to make it suitable for
-- System.Partition_Interface.Get_Unique_Remote_Pointer in order
-- to avoid memory leaks when the same remote object arrive on the
-- same partition through several paths;
-- 2) It also has the same dispatching table as the designated type D,
-- and thus can be used as an object designated by a value of type
-- R on any partition other than the one on which the object has
-- been created, since only dispatching calls will be performed and
-- the fields themselves will not be used. We call Derive_Subprograms
-- to fake half a derivation to ensure that the subprograms do have
-- the same dispatching table.
First_RCI_Subprogram_Id : constant := 2;
-- RCI subprograms are numbered starting at 2. The RCI receiver for
-- an RCI package can thus identify calls received through remote
-- access-to-subprogram dereferences by the fact that they have a
-- (primitive) subprogram id of 0, and 1 is used for the internal
-- RAS information lookup operation. (This is for the Garlic code
-- generation, where subprograms are identified by numbers; in the
-- PolyORB version, they are identified by name, with a numeric suffix
-- for homonyms.)
type Hash_Index is range 0 .. 50;
-----------------------
-- Local subprograms --
-----------------------
function Hash (F : Entity_Id) return Hash_Index;
-- DSA expansion associates stubs to distributed object types using
-- a hash table on entity ids.
function Hash (F : Name_Id) return Hash_Index;
-- The generation of subprogram identifiers requires an overload counter
-- to be associated with each remote subprogram names. These counters
-- are maintained in a hash table on name ids.
type Subprogram_Identifiers is record
Str_Identifier : String_Id;
Int_Identifier : Int;
end record;
package Subprogram_Identifier_Table is
new Simple_HTable (Header_Num => Hash_Index,
Element => Subprogram_Identifiers,
No_Element => (No_String, 0),
Key => Entity_Id,
Hash => Hash,
Equal => "=");
-- Mapping between a remote subprogram and the corresponding
-- subprogram identifiers.
package Overload_Counter_Table is
new Simple_HTable (Header_Num => Hash_Index,
Element => Int,
No_Element => 0,
Key => Name_Id,
Hash => Hash,
Equal => "=");
-- Mapping between a subprogram name and an integer that
-- counts the number of defining subprogram names with that
-- Name_Id encountered so far in a given context (an interface).
function Get_Subprogram_Ids (Def : Entity_Id) return Subprogram_Identifiers;
function Get_Subprogram_Id (Def : Entity_Id) return String_Id;
function Get_Subprogram_Id (Def : Entity_Id) return Int;
-- Given a subprogram defined in a RCI package, get its distribution
-- subprogram identifiers (the distribution identifiers are a unique
-- subprogram number, and the non-qualified subprogram name, in the
-- casing used for the subprogram declaration; if the name is overloaded,
-- a double underscore and a serial number are appended.
--
-- The integer identifier is used to perform remote calls with GARLIC;
-- the string identifier is used in the case of PolyORB.
--
-- Although the PolyORB DSA receiving stubs will make a caseless comparison
-- when receiving a call, the calling stubs will create requests with the
-- exact casing of the defining unit name of the called subprogram, so as
-- to allow calls to subprograms on distributed nodes that do distinguish
-- between casings.
--
-- NOTE: Another design would be to allow a representation clause on
-- subprogram specs: for Subp'Distribution_Identifier use "fooBar";
pragma Warnings (Off, Get_Subprogram_Id);
-- One homonym only is unreferenced (specific to the GARLIC version)
procedure Add_RAS_Dereference_TSS (N : Node_Id);
-- Add a subprogram body for RAS Dereference TSS
procedure Add_RAS_Proxy_And_Analyze
(Decls : List_Id;
Vis_Decl : Node_Id;
All_Calls_Remote_E : Entity_Id;
Proxy_Object_Addr : out Entity_Id);
-- Add the proxy type necessary to call the subprogram declared
-- by Vis_Decl through a remote access to subprogram type.
-- All_Calls_Remote_E must be Standard_True if a pragma All_Calls_Remote
-- applies, Standard_False otherwise. The new proxy type is appended
-- to Decls. Proxy_Object_Addr is a constant of type System.Address that
-- designates an instance of the proxy object.
function Build_Remote_Subprogram_Proxy_Type
(Loc : Source_Ptr;
ACR_Expression : Node_Id) return Node_Id;
-- Build and return a tagged record type definition for an RCI
-- subprogram proxy type.
-- ACR_Expression is use as the initialization value for
-- the All_Calls_Remote component.
function Build_Get_Unique_RP_Call
(Loc : Source_Ptr;
Pointer : Entity_Id;
Stub_Type : Entity_Id) return List_Id;
-- Build a call to Get_Unique_Remote_Pointer (Pointer), followed by a
-- tag fixup (Get_Unique_Remote_Pointer may have changed Pointer'Tag to
-- RACW_Stub_Type'Tag, while the desired tag is that of Stub_Type).
function Build_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.
procedure Add_Calling_Stubs_To_Declarations
(Pkg_Spec : Node_Id;
Decls : List_Id);
-- Add calling stubs to the declarative part
function Could_Be_Asynchronous (Spec : Node_Id) return Boolean;
-- Return True if nothing prevents the program whose specification is
-- given to be asynchronous (i.e. no out parameter).
function Pack_Entity_Into_Stream_Access
(Loc : Source_Ptr;
Stream : Node_Id;
Object : Entity_Id;
Etyp : Entity_Id := Empty) return Node_Id;
-- Pack Object (of type Etyp) into Stream. If Etyp is not given,
-- then Etype (Object) will be used if present. If the type is
-- constrained, then 'Write will be used to output the object,
-- If the type is unconstrained, 'Output will be used.
function Pack_Node_Into_Stream
(Loc : Source_Ptr;
Stream : Entity_Id;
Object : Node_Id;
Etyp : Entity_Id) return Node_Id;
-- Similar to above, with an arbitrary node instead of an entity
function Pack_Node_Into_Stream_Access
(Loc : Source_Ptr;
Stream : Node_Id;
Object : Node_Id;
Etyp : Entity_Id) return Node_Id;
-- Similar to above, with Stream instead of Stream'Access
function Make_Selected_Component
(Loc : Source_Ptr;
Prefix : Entity_Id;
Selector_Name : Name_Id) return Node_Id;
-- Return a selected_component whose prefix denotes the given entity,
-- and with the given Selector_Name.
function Scope_Of_Spec (Spec : Node_Id) return Entity_Id;
-- Return the scope represented by a given spec
procedure Set_Renaming_TSS
(Typ : Entity_Id;
Nam : Entity_Id;
TSS_Nam : TSS_Name_Type);
-- Create a renaming declaration of subprogram Nam,
-- and register it as a TSS for Typ with name TSS_Nam.
function Need_Extra_Constrained (Parameter : Node_Id) return Boolean;
-- Return True if the current parameter needs an extra formal to reflect
-- its constrained status.
function Is_RACW_Controlling_Formal
(Parameter : Node_Id;
Stub_Type : Entity_Id) return Boolean;
-- Return True if the current parameter is a controlling formal argument
-- of type Stub_Type or access to Stub_Type.
procedure Declare_Create_NVList
(Loc : Source_Ptr;
NVList : Entity_Id;
Decls : List_Id;
Stmts : List_Id);
-- Append the declaration of NVList to Decls, and its
-- initialization to Stmts.
function Add_Parameter_To_NVList
(Loc : Source_Ptr;
NVList : Entity_Id;
Parameter : Entity_Id;
Constrained : Boolean;
RACW_Ctrl : Boolean := False;
Any : Entity_Id) return Node_Id;
-- Return a call to Add_Item to add the Any corresponding
-- to the designated formal Parameter (with the indicated
-- Constrained status) to NVList. RACW_Ctrl must be set to
-- True for controlling formals of distributed object primitive
-- operations.
type Stub_Structure is record
Stub_Type : Entity_Id;
Stub_Type_Access : Entity_Id;
RPC_Receiver_Decl : Node_Id;
RACW_Type : Entity_Id;
end record;
-- This structure is necessary because of the two phases analysis of
-- a RACW declaration occurring in the same Remote_Types package as the
-- designated type. RACW_Type is any of the RACW types pointing on this
-- designated type, it is used here to save an anonymous type creation
-- for each primitive operation.
--
-- For a 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.
Empty_Stub_Structure : constant Stub_Structure :=
(Empty, Empty, Empty, 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
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;
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.
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;
--------------------------------------------
-- 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;
Declarations : List_Id);
-- Add declaration for TSSs for a given RACW type. The declarations are
-- added just after the declaration of the RACW type itself, while the
-- bodies are inserted at the end of Decls. Runtime-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 parition
RPC_Receiver : Node_Id;
-- An expression whose value is the address of the target RPC
-- receiver.
end case;
end record;
procedure Specific_Build_General_Calling_Stubs
(Decls : List_Id;
Statements : List_Id;
Target : RPC_Target;
Subprogram_Id : Node_Id;
Asynchronous : Node_Id := Empty;
Is_Known_Asynchronous : Boolean := False;
Is_Known_Non_Asynchronous : Boolean := False;
Is_Function : Boolean;
Spec : Node_Id;
Stub_Type : Entity_Id := Empty;
RACW_Type : Entity_Id := Empty;
Nod : Node_Id);
-- Build calling stubs for general purpose. The parameters are:
-- Decls : a place to put declarations
-- Statements : a place to put statements
-- Target : PCS-specific target information (see details
-- in RPC_Target declaration).
-- Subprogram_Id : a node containing the subprogram ID
-- Asynchronous : True if an APC must be made instead of an RPC.
-- The value needs not be supplied if one of the
-- Is_Known_... is True.
-- Is_Known_Async... : True if we know that this is asynchronous
-- Is_Known_Non_A... : True if we know that this is not asynchronous
-- Spec : a node with a Parameter_Specifications and
-- a Result_Definition if applicable
-- Stub_Type : in case of RACW stubs, parameters of type access
-- to Stub_Type will be marshalled using the
-- address of the object (the addr field) rather
-- than using the 'Write on the stub itself
-- Nod : used to provide sloc for generated code
function Specific_Build_Stub_Target
(Loc : Source_Ptr;
Decls : List_Id;
RCI_Locator : Entity_Id;
Controlling_Parameter : Entity_Id) return RPC_Target;
-- Build call target information nodes for use within calling stubs. In the
-- RCI case, RCI_Locator is the entity for the instance of RCI_Locator. If
-- for an RACW, Controlling_Parameter is the entity for the controlling
-- formal parameter used to determine the location of the target of the
-- call. Decls provides a location where variable declarations can be
-- appended to construct the necessary values.
procedure Specific_Build_Stub_Type
(RACW_Type : Entity_Id;
Stub_Type : Entity_Id;
Stub_Type_Decl : out Node_Id;
RPC_Receiver_Decl : out Node_Id);
-- Build a type declaration for the stub type associated with an RACW
-- type, and the necessary RPC receiver, if applicable. PCS-specific
-- ancillary subprogram for Add_Stub_Type. If no RPC receiver declaration
-- is generated, then RPC_Receiver_Decl is set to Empty.
procedure Specific_Build_RPC_Receiver_Body
(RPC_Receiver : Entity_Id;
Request : out Entity_Id;
Subp_Id : out Entity_Id;
Subp_Index : out Entity_Id;
Stmts : out List_Id;
Decl : out Node_Id);
-- Make a subprogram body for an RPC receiver, with the given
-- defining unit name. On return:
-- - Subp_Id is the subprogram identifier from the PCS.
-- - Subp_Index is the index in the list of subprograms
-- used for dispatching (a variable of type Subprogram_Id).
-- - Stmts is the place where the request dispatching
-- statements can occur,
-- - Decl is the subprogram body declaration.
function Specific_Build_Subprogram_Receiving_Stubs
(Vis_Decl : Node_Id;
Asynchronous : Boolean;
Dynamically_Asynchronous : Boolean := False;
Stub_Type : Entity_Id := Empty;
RACW_Type : Entity_Id := Empty;
Parent_Primitive : Entity_Id := Empty) return Node_Id;
-- Build the receiving stub for a given subprogram. The subprogram
-- declaration is also built by this procedure, and the value returned
-- is a N_Subprogram_Body. If a parameter of type access to Stub_Type is
-- found in the specification, then its address is read from the stream
-- instead of the object itself and converted into an access to
-- class-wide type before doing the real call using any of the RACW type
-- pointing on the designated type.
procedure Specific_Add_Obj_RPC_Receiver_Completion
(Loc : Source_Ptr;
Decls : List_Id;
RPC_Receiver : Entity_Id;
Stub_Elements : Stub_Structure);
-- Add the necessary code to Decls after the completion of generation
-- of the RACW RPC receiver described by Stub_Elements.
procedure Specific_Add_Receiving_Stubs_To_Declarations
(Pkg_Spec : Node_Id;
Decls : List_Id);
-- Add receiving stubs to the declarative part of an RCI unit
package GARLIC_Support is
-- Support for generating DSA code that uses the GARLIC PCS
-- The subprograms below provide the GARLIC versions of
-- the corresponding Specific_<subprogram> routine declared
-- above.
procedure Add_RACW_Features
(RACW_Type : Entity_Id;
Stub_Type : Entity_Id;
Stub_Type_Access : Entity_Id;
RPC_Receiver_Decl : Node_Id;
Declarations : List_Id);
procedure Add_RAST_Features
(Vis_Decl : Node_Id;
RAS_Type : Entity_Id);
procedure Build_General_Calling_Stubs
(Decls : List_Id;
Statements : List_Id;
Target_Partition : Entity_Id; -- From RPC_Target
Target_RPC_Receiver : Node_Id; -- From RPC_Target
Subprogram_Id : Node_Id;
Asynchronous : Node_Id := Empty;
Is_Known_Asynchronous : Boolean := False;
Is_Known_Non_Asynchronous : Boolean := False;
Is_Function : Boolean;
Spec : Node_Id;
Stub_Type : Entity_Id := Empty;
RACW_Type : Entity_Id := Empty;
Nod : Node_Id);
function Build_Stub_Target
(Loc : Source_Ptr;
Decls : List_Id;
RCI_Locator : Entity_Id;
Controlling_Parameter : Entity_Id) return RPC_Target;
procedure Build_Stub_Type
(RACW_Type : Entity_Id;
Stub_Type : Entity_Id;
Stub_Type_Decl : out Node_Id;
RPC_Receiver_Decl : out Node_Id);
function Build_Subprogram_Receiving_Stubs
(Vis_Decl : Node_Id;
Asynchronous : Boolean;
Dynamically_Asynchronous : Boolean := False;
Stub_Type : Entity_Id := Empty;
RACW_Type : Entity_Id := Empty;
Parent_Primitive : Entity_Id := Empty) return Node_Id;
procedure Add_Obj_RPC_Receiver_Completion
(Loc : Source_Ptr;
Decls : List_Id;
RPC_Receiver : Entity_Id;
Stub_Elements : Stub_Structure);
procedure Add_Receiving_Stubs_To_Declarations
(Pkg_Spec : Node_Id;
Decls : List_Id);
procedure Build_RPC_Receiver_Body
(RPC_Receiver : Entity_Id;
Request : out Entity_Id;
Subp_Id : out Entity_Id;
Subp_Index : out Entity_Id;
Stmts : out List_Id;
Decl : out Node_Id);
end GARLIC_Support;
package PolyORB_Support is
-- Support for generating DSA code that uses the PolyORB PCS
-- The subprograms below provide the PolyORB versions of
-- the corresponding Specific_<subprogram> routine declared
-- above.
procedure Add_RACW_Features
(RACW_Type : Entity_Id;
Desig : Entity_Id;
Stub_Type : Entity_Id;
Stub_Type_Access : Entity_Id;
RPC_Receiver_Decl : Node_Id;
Declarations : List_Id);
procedure Add_RAST_Features
(Vis_Decl : Node_Id;
RAS_Type : Entity_Id);
procedure Build_General_Calling_Stubs
(Decls : List_Id;
Statements : List_Id;
Target_Object : Node_Id; -- From RPC_Target
Subprogram_Id : Node_Id;
Asynchronous : Node_Id := Empty;
Is_Known_Asynchronous : Boolean := False;
Is_Known_Non_Asynchronous : Boolean := False;
Is_Function : Boolean;
Spec : Node_Id;
Stub_Type : Entity_Id := Empty;
RACW_Type : Entity_Id := Empty;
Nod : Node_Id);
function Build_Stub_Target
(Loc : Source_Ptr;
Decls : List_Id;
RCI_Locator : Entity_Id;
Controlling_Parameter : Entity_Id) return RPC_Target;
procedure Build_Stub_Type
(RACW_Type : Entity_Id;
Stub_Type : Entity_Id;
Stub_Type_Decl : out Node_Id;
RPC_Receiver_Decl : out Node_Id);
function Build_Subprogram_Receiving_Stubs
(Vis_Decl : Node_Id;
Asynchronous : Boolean;
Dynamically_Asynchronous : Boolean := False;
Stub_Type : Entity_Id := Empty;
RACW_Type : Entity_Id := Empty;
Parent_Primitive : Entity_Id := Empty) return Node_Id;
procedure Add_Obj_RPC_Receiver_Completion
(Loc : Source_Ptr;
Decls : List_Id;
RPC_Receiver : Entity_Id;
Stub_Elements : Stub_Structure);
procedure Add_Receiving_Stubs_To_Declarations
(Pkg_Spec : Node_Id;
Decls : List_Id);
procedure Build_RPC_Receiver_Body
(RPC_Receiver : Entity_Id;
Request : out Entity_Id;
Subp_Id : out Entity_Id;
Subp_Index : out Entity_Id;
Stmts : out List_Id;
Decl : out Node_Id);
procedure Reserve_NamingContext_Methods;
-- Mark the method names for interface NamingContext as already used in
-- the overload table, so no clashes occur with user code (with the
-- PolyORB PCS, RCIs Implement The NamingContext interface to allow
-- their methods to be accessed as objects, for the implementation of
-- remote access-to-subprogram types).
package Helpers is
-- Routines to build distribtion helper subprograms for user-defined
-- types. For implementation of the Distributed systems annex (DSA)
-- over the PolyORB generic middleware components, it is necessary to
-- generate several supporting subprograms for each application data
-- type used in inter-partition communication. These subprograms are:
-- * a Typecode function returning a high-level description of the
-- type's structure;
-- * two conversion functions allowing conversion of values of the
-- type from and to the generic data containers used by PolyORB.
-- These generic containers are called 'Any' type values after
-- the CORBA terminology, and hence the conversion subprograms
-- are named To_Any and From_Any.
function Build_From_Any_Call
(Typ : Entity_Id;
N : Node_Id;
Decls : List_Id) return Node_Id;
-- Build call to From_Any attribute function of type Typ with
-- expression N as actual parameter. Decls is the declarations list
-- for an appropriate enclosing scope of the point where the call
-- will be inserted; if the From_Any attribute for Typ needs to be
-- generated at this point, its declaration is appended to Decls.
procedure Build_From_Any_Function
(Loc : Source_Ptr;
Typ : Entity_Id;
Decl : out Node_Id;
Fnam : out Entity_Id);
-- Build From_Any attribute function for Typ. Loc is the reference
-- location for generated nodes, Typ is the type for which the
-- conversion function is generated. On return, Decl and Fnam contain
-- the declaration and entity for the newly-created function.
function Build_To_Any_Call
(N : Node_Id;
Decls : List_Id) return Node_Id;
-- Build call to To_Any attribute function with expression as actual
-- parameter. Decls is the declarations list for an appropriate
-- enclosing scope of the point where the call will be inserted; if
-- the To_Any attribute for Typ needs to be generated at this point,
-- its declaration is appended to Decls.
procedure Build_To_Any_Function
(Loc : Source_Ptr;
Typ : Entity_Id;
Decl : out Node_Id;
Fnam : out Entity_Id);
-- Build To_Any attribute function for Typ. Loc is the reference
-- location for generated nodes, Typ is the type for which the
-- conversion function is generated. On return, Decl and Fnam contain
-- the declaration and entity for the newly-created function.
function Build_TypeCode_Call
(Loc : Source_Ptr;
Typ : Entity_Id;
Decls : List_Id) return Node_Id;
-- Build call to TypeCode attribute function for Typ. Decls is the
-- declarations list for an appropriate enclosing scope of the point
-- where the call will be inserted; if the To_Any attribute for Typ
-- needs to be generated at this point, its declaration is appended
-- to Decls.
procedure Build_TypeCode_Function
(Loc : Source_Ptr;
Typ : Entity_Id;
Decl : out Node_Id;
Fnam : out Entity_Id);
-- Build TypeCode attribute function for Typ. Loc is the reference
-- location for generated nodes, Typ is the type for which the
-- conversion function is generated. On return, Decl and Fnam contain
-- the declaration and entity for the newly-created function.
procedure Build_Name_And_Repository_Id
(E : Entity_Id;
Name_Str : out String_Id;
Repo_Id_Str : out String_Id);
-- In the PolyORB distribution model, each distributed object type
-- and each distributed operation has a globally unique identifier,
-- its Repository Id. This subprogram builds and returns two strings
-- for entity E (a distributed object type or operation): one
-- containing the name of E, the second containing its repository id.
end Helpers;
end PolyORB_Support;
------------------------------------
-- Local variables and structures --
------------------------------------
RCI_Cache : Node_Id;
-- Needs comments ???
Output_From_Constrained : constant array (Boolean) of Name_Id :=
(False => Name_Output,
True => Name_Write);
-- The attribute to choose depending on the fact that the parameter
-- is constrained or not. There is no such thing as Input_From_Constrained
-- since this require separate mechanisms ('Input is a function while
-- 'Read is a procedure).
---------------------------------------
-- Add_Calling_Stubs_To_Declarations --
---------------------------------------
procedure Add_Calling_Stubs_To_Declarations
(Pkg_Spec : Node_Id;
Decls : List_Id)
is
Current_Subprogram_Number : Int := First_RCI_Subprogram_Id;
-- Subprogram id 0 is reserved for calls received from
-- remote access-to-subprogram dereferences.
Current_Declaration : Node_Id;
Loc : constant Source_Ptr := Sloc (Pkg_Spec);
RCI_Instantiation : Node_Id;
Subp_Stubs : Node_Id;
Subp_Str : String_Id;
begin
-- The first thing added is an instantiation of the generic package
-- System.Partition_Interface.RCI_Locator with the name of this
-- remote package. This will act as an interface with the name server
-- to determine the Partition_ID and the RPC_Receiver for the
-- receiver of this package.
RCI_Instantiation := RCI_Package_Locator (Loc, Pkg_Spec);
RCI_Cache := Defining_Unit_Name (RCI_Instantiation);
Append_To (Decls, RCI_Instantiation);
Analyze (RCI_Instantiation);
-- For each subprogram declaration visible in the spec, we do
-- build a body. We also increment a counter to assign a different
-- Subprogram_Id to each subprograms. The receiving stubs processing
-- do use the same mechanism and will thus assign the same Id and
-- do the correct dispatching.
Overload_Counter_Table.Reset;
PolyORB_Support.Reserve_NamingContext_Methods;
Current_Declaration := First (Visible_Declarations (Pkg_Spec));
while Present (Current_Declaration) loop
if Nkind (Current_Declaration) = N_Subprogram_Declaration
and then Comes_From_Source (Current_Declaration)
then
Assign_Subprogram_Identifier (
Defining_Unit_Name (Specification (Current_Declaration)),
Current_Subprogram_Number,
Subp_Str);
Subp_Stubs :=
Build_Subprogram_Calling_Stubs (
Vis_Decl => Current_Declaration,
Subp_Id =>
Build_Subprogram_Id (Loc,
Defining_Unit_Name (Specification (Current_Declaration))),
Asynchronous =>
Nkind (Specification (Current_Declaration)) =
N_Procedure_Specification
and then
Is_Asynchronous (Defining_Unit_Name (Specification
(Current_Declaration))));
Append_To (Decls, Subp_Stubs);
Analyze (Subp_Stubs);
Current_Subprogram_Number := Current_Subprogram_Number + 1;
end if;
Next (Current_Declaration);
end loop;
end Add_Calling_Stubs_To_Declarations;
-----------------------------
-- Add_Parameter_To_NVList --
-----------------------------
function Add_Parameter_To_NVList
(Loc : Source_Ptr;
NVList : Entity_Id;
Parameter : Entity_Id;
Constrained : Boolean;
RACW_Ctrl : Boolean := False;
Any : Entity_Id) return Node_Id
is
Parameter_Name_String : String_Id;
Parameter_Mode : Node_Id;
function Parameter_Passing_Mode
(Loc : Source_Ptr;
Parameter : Entity_Id;
Constrained : Boolean) return Node_Id;
-- Return an expression that denotes the parameter passing
-- mode to be used for Parameter in distribution stubs,
-- where Constrained is Parameter's constrained status.
----------------------------
-- Parameter_Passing_Mode --
----------------------------
function Parameter_Passing_Mode
(Loc : Source_Ptr;
Parameter : Entity_Id;
Constrained : Boolean) return Node_Id
is
Lib_RE : RE_Id;
begin
if Out_Present (Parameter) then
if In_Present (Parameter)
or else not Constrained
then
-- Unconstrained formals must be translated
-- to 'in' or 'inout', not 'out', because
-- they need to be constrained by the actual.
Lib_RE := RE_Mode_Inout;
else
Lib_RE := RE_Mode_Out;
end if;
else
Lib_RE := RE_Mode_In;
end if;
return New_Occurrence_Of (RTE (Lib_RE), Loc);
end Parameter_Passing_Mode;
-- Start of processing for Add_Parameter_To_NVList
begin
if Nkind (Parameter) = N_Defining_Identifier then
Get_Name_String (Chars (Parameter));
else
Get_Name_String (Chars (Defining_Identifier
(Parameter)));
end if;
Parameter_Name_String := String_From_Name_Buffer;
if RACW_Ctrl then
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));
Decls : List_Id :=
List_Containing (Declaration_Node (RACW_Type));
Same_Scope : constant Boolean :=
Scope (Desig) = Scope (RACW_Type);
Stub_Type : Entity_Id;
Stub_Type_Access : Entity_Id;
RPC_Receiver_Decl : Node_Id;
Existing : Boolean;
begin
if not Expander_Active then
return;
end if;
if Same_Scope then
-- We are declaring a RACW in the same package than its designated
-- type, so the list to use for late declarations must be the
-- private part of the package. We do know that this private part
-- exists since the designated type has to be a private one.
Decls := Private_Declarations
(Package_Specification_Of_Scope (Current_Scope));
elsif Nkind (Parent (Decls)) = N_Package_Specification
and then Present (Private_Declarations (Parent (Decls)))
then
Decls := Private_Declarations (Parent (Decls));
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,
Existing => Existing);
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,
Declarations => Decls);
if not Same_Scope and then not Existing then
-- The RACW has been declared in another scope than the designated
-- type and has not been handled by another RACW in the same package
-- as the first one, so add primitive for the stub type here.
Add_RACW_Primitive_Declarations_And_Bodies
(Designated_Type => Desig,
Insertion_Node => RPC_Receiver_Decl,
Decls => Decls);
else
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;
Decls : List_Id)
is
-- Set Sloc of generated declaration copy of insertion node Sloc, so
-- the declarations are recognized as belonging to the current package.
Loc : constant Source_Ptr := Sloc (Insertion_Node);
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);
Current_Insertion_Node : Node_Id := Insertion_Node;
RPC_Receiver : Entity_Id;
RPC_Receiver_Statements : List_Id;
RPC_Receiver_Case_Alternatives : constant List_Id := New_List;
RPC_Receiver_Elsif_Parts : List_Id;
RPC_Receiver_Request : Entity_Id;
RPC_Receiver_Subp_Id : Entity_Id;
RPC_Receiver_Subp_Index : Entity_Id;
Subp_Str : String_Id;
Current_Primitive_Elmt : Elmt_Id;
Current_Primitive : Entity_Id;
Current_Primitive_Body : Node_Id;
Current_Primitive_Spec : Node_Id;
Current_Primitive_Decl : Node_Id;
Current_Primitive_Number : Int := 0;
Current_Primitive_Alias : Node_Id;
Current_Receiver : Entity_Id;
Current_Receiver_Body : Node_Id;
RPC_Receiver_Decl : Node_Id;
Possibly_Asynchronous : Boolean;
begin
if not Expander_Active then
return;
end if;
if not Is_RAS then
RPC_Receiver := Make_Defining_Identifier (Loc,
New_Internal_Name ('P'));
Specific_Build_RPC_Receiver_Body (
RPC_Receiver => RPC_Receiver,
Request => RPC_Receiver_Request,
Subp_Id => RPC_Receiver_Subp_Id,
Subp_Index => RPC_Receiver_Subp_Index,
Stmts => RPC_Receiver_Statements,
Decl => RPC_Receiver_Decl);
if Get_PCS_Name = Name_PolyORB_DSA then
-- For the case of PolyORB, we need to map a textual operation
-- name into a primitive index. Currently we do so using a
-- simple sequence of string comparisons.
RPC_Receiver_Elsif_Parts := New_List;
end if;
end if;
-- Build callers, receivers for every primitive operations and a RPC
-- receiver for this type.
if Present (Primitive_Operations (Designated_Type)) then
Overload_Counter_Table.Reset;
Current_Primitive_Elmt :=
First_Elmt (Primitive_Operations (Designated_Type));
while Current_Primitive_Elmt /= No_Elmt loop
Current_Primitive := Node (Current_Primitive_Elmt);
-- Copy the primitive of all the parents, except predefined
-- ones that are not remotely dispatching.
if Chars (Current_Primitive) /= Name_uSize
and then Chars (Current_Primitive) /= Name_uAlignment
and then not Is_TSS (Current_Primitive, TSS_Deep_Finalize)
then
-- The first thing to do is build an up-to-date copy of
-- the spec with all the formals referencing Designated_Type
-- transformed into formals referencing Stub_Type. Since this
-- primitive may have been inherited, go back the alias chain
-- until the real primitive has been found.
Current_Primitive_Alias := Current_Primitive;
while Present (Alias (Current_Primitive_Alias)) loop
pragma Assert
(Current_Primitive_Alias
/= Alias (Current_Primitive_Alias));
Current_Primitive_Alias := Alias (Current_Primitive_Alias);
end loop;
Current_Primitive_Spec :=
Copy_Specification (Loc,
Spec => Parent (Current_Primitive_Alias),
Object_Type => Designated_Type,
Stub_Type => Stub_Elements.Stub_Type);
Current_Primitive_Decl :=
Make_Subprogram_Declaration (Loc,
Specification => Current_Primitive_Spec);
Insert_After (Current_Insertion_Node, Current_Primitive_Decl);
Analyze (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);
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 (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.
-- Build the receiver stubs
if 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 (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,
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 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 (Decls, RPC_Receiver_Decl);
Specific_Add_Obj_RPC_Receiver_Completion (Loc,
Decls, RPC_Receiver, Stub_Elements);
end if;
-- Do not analyze RPC receiver at this stage since it will otherwise
-- reference subprograms that have not been analyzed yet. It will
-- be analyzed in the regular flow.
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);
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);
RACW_Primitive_Name : Node_Id;
Proc : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Chars => Make_TSS_Name (RAS_Type, TSS_RAS_Dereference));
Proc_Spec : Node_Id;
Param_Specs : List_Id;
Param_Assoc : constant List_Id := New_List;
Stmts : constant List_Id := New_List;
RAS_Parameter : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('P'));
Is_Function : constant Boolean :=
Nkind (Type_Def) = N_Access_Function_Definition;
Is_Degenerate : Boolean;
-- Set to True if the subprogram_specification for this RAS has
-- an anonymous access parameter (see Process_Remote_AST_Declaration).
Spec : constant Node_Id := Type_Def;
Current_Parameter : Node_Id;
-- Start of processing for Add_RAS_Dereference_TSS
begin
-- The Dereference TSS for a remote access-to-subprogram type
-- has the form:
-- [function|procedure] ras_typeRD (RAS_Value, <RAS_Parameters>)
-- [return <>]
-- This is called whenever a value of a RAS type is dereferenced
-- First construct a list of parameter specifications:
-- The first formal is the RAS values
Param_Specs := New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier => RAS_Parameter,
In_Present => True,
Parameter_Type =>
New_Occurrence_Of (Fat_Type, Loc)));
-- The following formals are copied from the type declaration
Is_Degenerate := False;
Current_Parameter := First (Parameter_Specifications (Type_Def));
Parameters : while Present (Current_Parameter) loop
if Nkind (Parameter_Type (Current_Parameter))
= N_Access_Definition
then
Is_Degenerate := True;
end if;
Append_To (Param_Specs,
Make_Parameter_Specification (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc,
Chars => Chars (Defining_Identifier (Current_Parameter))),
In_Present => In_Present (Current_Parameter),
Out_Present => Out_Present (Current_Parameter),
Parameter_Type =>
New_Copy_Tree (Parameter_Type (Current_Parameter)),
Expression =>
New_Copy_Tree (Expression (Current_Parameter))));
Append_To (Param_Assoc,
Make_Identifier (Loc,
Chars => Chars (Defining_Identifier (Current_Parameter))));
Next (Current_Parameter);
end loop Parameters;
if Is_Degenerate then
Prepend_To (Param_Assoc, New_Occurrence_Of (RAS_Parameter, Loc));
-- Generate a dummy body. This code will never actually be executed,
-- because null is the only legal value for a degenerate RAS type.
-- For legality's sake (in order to avoid generating a function
-- that does not contain a return statement), we include a dummy
-- recursive call on the TSS itself.
Append_To (Stmts,
Make_Raise_Program_Error (Loc, Reason => PE_Explicit_Raise));
RACW_Primitive_Name := New_Occurrence_Of (Proc, Loc);
else
-- For a normal RAS type, we cast the RAS formal to the corresponding
-- tagged type, and perform a dispatching call to its Call
-- primitive operation.
Prepend_To (Param_Assoc,
Unchecked_Convert_To (RACW_Type,
New_Occurrence_Of (RAS_Parameter, Loc)));
RACW_Primitive_Name := Make_Selected_Component (Loc,
Prefix => Scope (RACW_Type),
Selector_Name => Name_Call);
end if;
if Is_Function then
Append_To (Stmts,
Make_Return_Statement (Loc,
Expression =>
Make_Function_Call (Loc,
Name =>
RACW_Primitive_Name,
Parameter_Associations => Param_Assoc)));
else
Append_To (Stmts,
Make_Procedure_Call_Statement (Loc,
Name =>
RACW_Primitive_Name,
Parameter_Associations => Param_Assoc));
end if;
-- Build the complete subprogram
if Is_Function then
Proc_Spec :=
Make_Function_Specification (Loc,
Defining_Unit_Name => Proc,
Parameter_Specifications => Param_Specs,
Result_Definition =>
New_Occurrence_Of (
Entity (Result_Definition (Spec)), Loc));
Set_Ekind (Proc, E_Function);
Set_Etype (Proc,
New_Occurrence_Of (Entity (Result_Definition (Spec)), Loc));
else
Proc_Spec :=
Make_Procedure_Specification (Loc,
Defining_Unit_Name => Proc,
Parameter_Specifications => Param_Specs);
Set_Ekind (Proc, E_Procedure);
Set_Etype (Proc, Standard_Void_Type);
end if;
Discard_Node (
Make_Subprogram_Body (Loc,
Specification => Proc_Spec,
Declarations => New_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Stmts)));
Set_TSS (Fat_Type, Proc);
end Add_RAS_Dereference_TSS;
-------------------------------
-- Add_RAS_Proxy_And_Analyze --
-------------------------------
procedure Add_RAS_Proxy_And_Analyze
(Decls : List_Id;
Vis_Decl : Node_Id;
All_Calls_Remote_E : Entity_Id;
Proxy_Object_Addr : out Entity_Id)
is
Loc : constant Source_Ptr := Sloc (Vis_Decl);
Subp_Name : constant Entity_Id :=
Defining_Unit_Name (Specification (Vis_Decl));
Pkg_Name : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Chars =>
New_External_Name (Chars (Subp_Name), 'P', -1));
Proxy_Type : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Chars =>
New_External_Name (
Related_Id => Chars (Subp_Name),
Suffix => 'P'));
Proxy_Type_Full_View : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Chars (Proxy_Type));
Subp_Decl_Spec : constant Node_Id :=
Build_RAS_Primitive_Specification
(Subp_Spec => Specification (Vis_Decl),
Remote_Object_Type => Proxy_Type);
Subp_Body_Spec : constant Node_Id :=
Build_RAS_Primitive_Specification
(Subp_Spec => Specification (Vis_Decl),
Remote_Object_Type => Proxy_Type);
Vis_Decls : constant List_Id := New_List;
Pvt_Decls : constant List_Id := New_List;
Actuals : constant List_Id := New_List;
Formal : Node_Id;
Perform_Call : Node_Id;
begin
-- type subpP is tagged limited private;
Append_To (Vis_Decls,
Make_Private_Type_Declaration (Loc,
Defining_Identifier => Proxy_Type,
Tagged_Present => True,
Limited_Present => True));
-- [subprogram] Call
-- (Self : access subpP;
-- ...other-formals...)
-- [return T];
Append_To (Vis_Decls,
Make_Subprogram_Declaration (Loc,
Specification => Subp_Decl_Spec));
-- A : constant System.Address;
Proxy_Object_Addr := Make_Defining_Identifier (Loc, Name_uA);
Append_To (Vis_Decls,
Make_Object_Declaration (Loc,
Defining_Identifier =>
Proxy_Object_Addr,
Constant_Present =>
True,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Address), Loc)));
-- private
-- type subpP is tagged limited record
-- All_Calls_Remote : Boolean := [All_Calls_Remote?];
-- ...
-- end record;
Append_To (Pvt_Decls,
Make_Full_Type_Declaration (Loc,
Defining_Identifier =>
Proxy_Type_Full_View,
Type_Definition =>
Build_Remote_Subprogram_Proxy_Type (Loc,
New_Occurrence_Of (All_Calls_Remote_E, Loc))));
-- Trick semantic analysis into swapping the public and
-- full view when freezing the public view.
Set_Comes_From_Source (Proxy_Type_Full_View, True);
-- procedure Call
-- (Self : access O;
-- ...other-formals...) is
-- begin
-- P (...other-formals...);
-- end Call;
-- function Call
-- (Self : access O;
-- ...other-formals...)
-- return T is
-- begin
-- return F (...other-formals...);
-- end Call;
if Nkind (Subp_Decl_Spec) = N_Procedure_Specification then
Perform_Call :=
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (Subp_Name, Loc),
Parameter_Associations =>
Actuals);
else
Perform_Call :=
Make_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;
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;
Existing := True;
return;
end if;
Existing := False;
Stub_Type :=
Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
Stub_Type_Access :=
Make_Defining_Identifier (Loc,
New_External_Name (
Related_Id => Chars (Stub_Type),
Suffix => 'A'));
Specific_Build_Stub_Type (
RACW_Type, Stub_Type,
Stub_Type_Decl, RPC_Receiver_Decl);
Stub_Type_Access_Decl :=
Make_Full_Type_Declaration (Loc,
Defining_Identifier => Stub_Type_Access,
Type_Definition =>
Make_Access_To_Object_Definition (Loc,
All_Present => True,
Subtype_Indication => New_Occurrence_Of (Stub_Type, Loc)));
Append_To (Decls, Stub_Type_Decl);
Analyze (Last (Decls));
Append_To (Decls, Stub_Type_Access_Decl);
Analyze (Last (Decls));
-- This is in no way a type derivation, but we fake it to make
-- sure that the dispatching table gets built with the corresponding
-- primitive operations at the right place.
Derive_Subprograms (Parent_Type => Designated_Type,
Derived_Type => Stub_Type);
if Present (RPC_Receiver_Decl) then
Append_To (Decls, RPC_Receiver_Decl);
else
RPC_Receiver_Decl := Last (Decls);
end if;
Stubs_Table.Set (Designated_Type,
(Stub_Type => Stub_Type,
Stub_Type_Access => Stub_Type_Access,
RPC_Receiver_Decl => RPC_Receiver_Decl,
RACW_Type => RACW_Type));
end Add_Stub_Type;
----------------------------------
-- 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_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;
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
Current_Parameter := First_Parameter;
while Present (Current_Parameter) loop
if (Nkind (Parameter_Type (Current_Parameter)) = N_Access_Definition
or else
Is_Constrained (Etype (Parameter_Type (Current_Parameter)))
or else
Is_Elementary_Type (Etype (Parameter_Type (Current_Parameter))))
and then not (For_RAS and then Current_Parameter = First_Parameter)
then
Append_To (Constrained_List, New_Copy (Current_Parameter));
else
Append_To (Unconstrained_List, New_Copy (Current_Parameter));
end if;
Next (Current_Parameter);
end loop;
-- Unconstrained parameters are returned first
Append_List_To (Unconstrained_List, Constrained_List);
return Unconstrained_List;
end Build_Ordered_Parameters_List;
----------------------------------
-- Build_Passive_Partition_Stub --
----------------------------------
procedure Build_Passive_Partition_Stub (U : Node_Id) is
Pkg_Spec : Node_Id;
Pkg_Name : String_Id;
L : List_Id;
Reg : Node_Id;
Loc : constant Source_Ptr := Sloc (U);
begin
-- Verify that the implementation supports distribution, by accessing
-- a type defined in the proper version of system.rpc
declare
Dist_OK : Entity_Id;
pragma Warnings (Off, Dist_OK);
begin
Dist_OK := RTE (RE_Params_Stream_Type);
end;
-- Use body if present, spec otherwise
if Nkind (U) = N_Package_Declaration then
Pkg_Spec := Specification (U);
L := Visible_Declarations (Pkg_Spec);
else
Pkg_Spec := Parent (Corresponding_Spec (U));
L := Declarations (U);
end if;
Get_Library_Unit_Name_String (Pkg_Spec);
Pkg_Name := String_From_Name_Buffer;
Reg :=
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Register_Passive_Package), Loc),
Parameter_Associations => New_List (
Make_String_Literal (Loc, Pkg_Name),
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc),
Attribute_Name =>
Name_Version)));
Append_To (L, Reg);
Analyze (Reg);
end Build_Passive_Partition_Stub;
--------------------------------------
-- Build_RPC_Receiver_Specification --
--------------------------------------
function Build_RPC_Receiver_Specification
(RPC_Receiver : Entity_Id;
Request_Parameter : Entity_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (RPC_Receiver);
begin
return
Make_Procedure_Specification (Loc,
Defining_Unit_Name => RPC_Receiver,
Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier => Request_Parameter,
Parameter_Type =>
New_Occurrence_Of (RTE (RE_Request_Access), Loc))));
end Build_RPC_Receiver_Specification;
----------------------------------------
-- Build_Remote_Subprogram_Proxy_Type --
----------------------------------------
function Build_Remote_Subprogram_Proxy_Type
(Loc : Source_Ptr;
ACR_Expression : Node_Id) return Node_Id
is
begin
return
Make_Record_Definition (Loc,
Tagged_Present => True,
Limited_Present => True,
Component_List =>
Make_Component_List (Loc,
Component_Items => New_List (
Make_Component_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc,
Name_All_Calls_Remote),
Component_Definition =>
Make_Component_Definition (Loc,
Subtype_Indication =>
New_Occurrence_Of (Standard_Boolean, Loc)),
Expression =>
ACR_Expression),
Make_Component_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc,
Name_Receiver),
Component_Definition =>
Make_Component_Definition (Loc,
Subtype_Indication =>
New_Occurrence_Of (RTE (RE_Address), Loc)),
Expression =>
New_Occurrence_Of (RTE (RE_Null_Address), Loc)),
Make_Component_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc,
Name_Subp_Id),
Component_Definition =>
Make_Component_Definition (Loc,
Subtype_Indication =>
New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc))))));
end Build_Remote_Subprogram_Proxy_Type;
------------------------------------
-- Build_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
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;
Object_Type : Entity_Id := Empty;
Stub_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;
Current_Etype : Entity_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
Current_Etype := Entity (Subtype_Mark (Current_Type));
if Present (Object_Type) then
pragma Assert (
Root_Type (Current_Etype) = Root_Type (Object_Type));
Current_Type :=
Make_Access_Definition (Loc,
Subtype_Mark => New_Occurrence_Of (Stub_Type, Loc),
Null_Exclusion_Present =>
Null_Exclusion_Present (Current_Type));
else
Current_Type :=
Make_Access_Definition (Loc,
Subtype_Mark =>
New_Occurrence_Of (Current_Etype, Loc),
Null_Exclusion_Present =>
Null_Exclusion_Present (Current_Type));
end if;
else
Current_Etype := Entity (Current_Type);
if Present (Object_Type)
and then Current_Etype = Object_Type
then
Current_Type := New_Occurrence_Of (Stub_Type, Loc);
else
Current_Type := New_Occurrence_Of (Current_Etype, Loc);
end if;
end if;
New_Identifier := Make_Defining_Identifier (Loc,
Chars (Current_Identifier));
Append_To (Parameters,
Make_Parameter_Specification (Loc,
Defining_Identifier => New_Identifier,
Parameter_Type => Current_Type,
In_Present => In_Present (Current_Parameter),
Out_Present => Out_Present (Current_Parameter),
Expression =>
New_Copy_Tree (Expression (Current_Parameter))));
-- For a regular formal parameter (that needs to be marshalled
-- in the context of remote calls), set the Etype now, because
-- marshalling processing might need it.
if Is_Entity_Name (Current_Type) then
Set_Etype (New_Identifier, Entity (Current_Type));
-- Current_Type is an access definition, special processing
-- (not requiring etype) will occur for marshalling.
else
null;
end if;
Next (Current_Parameter);
end loop;
end if;
case Nkind (Spec) is
when N_Function_Specification | N_Access_Function_Definition =>
return
Make_Function_Specification (Loc,
Defining_Unit_Name =>
Make_Defining_Identifier (Loc,
Chars => Name_For_New_Spec),
Parameter_Specifications => Parameters,
Result_Definition =>
New_Occurrence_Of (Entity (Result_Definition (Spec)), Loc));
when N_Procedure_Specification | N_Access_Procedure_Definition =>
return
Make_Procedure_Specification (Loc,
Defining_Unit_Name =>
Make_Defining_Identifier (Loc,
Chars => Name_For_New_Spec),
Parameter_Specifications => Parameters);
when others =>
raise Program_Error;
end case;
end Copy_Specification;
---------------------------
-- Could_Be_Asynchronous --
---------------------------
function Could_Be_Asynchronous (Spec : Node_Id) return Boolean is
Current_Parameter : Node_Id;
begin
if Present (Parameter_Specifications (Spec)) then
Current_Parameter := First (Parameter_Specifications (Spec));
while Present (Current_Parameter) loop
if Out_Present (Current_Parameter) then
return False;
end if;
Next (Current_Parameter);
end loop;
end if;
return True;
end Could_Be_Asynchronous;
---------------------------
-- Declare_Create_NVList --
---------------------------
procedure Declare_Create_NVList
(Loc : Source_Ptr;
NVList : Entity_Id;
Decls : List_Id;
Stmts : List_Id)
is
begin
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => NVList,
Aliased_Present => False,
Object_Definition =>
New_Occurrence_Of (RTE (RE_NVList_Ref), Loc)));
Append_To (Stmts,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTE (RE_NVList_Create), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (NVList, Loc))));
end Declare_Create_NVList;
---------------------------------------------
-- Expand_All_Calls_Remote_Subprogram_Call --
---------------------------------------------
procedure Expand_All_Calls_Remote_Subprogram_Call (N : Node_Id) is
Called_Subprogram : constant Entity_Id := Entity (Name (N));
RCI_Package : constant Entity_Id := Scope (Called_Subprogram);
Loc : constant Source_Ptr := Sloc (N);
RCI_Locator : Node_Id;
RCI_Cache : Entity_Id;
Calling_Stubs : Node_Id;
E_Calling_Stubs : Entity_Id;
begin
E_Calling_Stubs := RCI_Calling_Stubs_Table.Get (Called_Subprogram);
if E_Calling_Stubs = Empty then
RCI_Cache := RCI_Locator_Table.Get (RCI_Package);
if RCI_Cache = Empty then
RCI_Locator :=
RCI_Package_Locator
(Loc, Specification (Unit_Declaration_Node (RCI_Package)));
Prepend_To (Current_Sem_Unit_Declarations, RCI_Locator);
-- The RCI_Locator package is inserted at the top level in the
-- current unit, and must appear in the proper scope, so that it
-- is not prematurely removed by the GCC back-end.
declare
Scop : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
begin
if Ekind (Scop) = E_Package_Body then
New_Scope (Spec_Entity (Scop));
elsif Ekind (Scop) = E_Subprogram_Body then
New_Scope
(Corresponding_Spec (Unit_Declaration_Node (Scop)));
else
New_Scope (Scop);
end if;
Analyze (RCI_Locator);
Pop_Scope;
end;
RCI_Cache := Defining_Unit_Name (RCI_Locator);
else
RCI_Locator := Parent (RCI_Cache);
end if;
Calling_Stubs := Build_Subprogram_Calling_Stubs
(Vis_Decl => Parent (Parent (Called_Subprogram)),
Subp_Id =>
Build_Subprogram_Id (Loc, Called_Subprogram),
Asynchronous => Nkind (N) = N_Procedure_Call_Statement
and then
Is_Asynchronous (Called_Subprogram),
Locator => RCI_Cache,
New_Name => New_Internal_Name ('S'));
Insert_After (RCI_Locator, Calling_Stubs);
Analyze (Calling_Stubs);
E_Calling_Stubs := Defining_Unit_Name (Specification (Calling_Stubs));
end if;
Rewrite (Name (N), New_Occurrence_Of (E_Calling_Stubs, Loc));
end Expand_All_Calls_Remote_Subprogram_Call;
---------------------------------
-- Expand_Calling_Stubs_Bodies --
---------------------------------
procedure Expand_Calling_Stubs_Bodies (Unit_Node : Node_Id) is
Spec : constant Node_Id := Specification (Unit_Node);
Decls : constant List_Id := Visible_Declarations (Spec);
begin
New_Scope (Scope_Of_Spec (Spec));
Add_Calling_Stubs_To_Declarations
(Specification (Unit_Node), Decls);
Pop_Scope;
end Expand_Calling_Stubs_Bodies;
-----------------------------------
-- Expand_Receiving_Stubs_Bodies --
-----------------------------------
procedure Expand_Receiving_Stubs_Bodies (Unit_Node : Node_Id) is
Spec : Node_Id;
Decls : List_Id;
Temp : 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;
New_Scope (Scope_Of_Spec (Spec));
Specific_Add_Receiving_Stubs_To_Declarations (Spec, Decls);
else
Spec :=
Package_Specification_Of_Scope (Corresponding_Spec (Unit_Node));
Decls := Declarations (Unit_Node);
New_Scope (Scope_Of_Spec (Unit_Node));
Temp := New_List;
Specific_Add_Receiving_Stubs_To_Declarations (Spec, Temp);
Insert_List_Before (First (Decls), Temp);
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;
Declarations : List_Id);
-- Add Read attribute in Decls for the RACW type. The Read attribute
-- is added right after the RACW_Type declaration while the body is
-- inserted after Declarations.
procedure Add_RACW_Write_Attribute
(RACW_Type : Entity_Id;
Stub_Type : Entity_Id;
Stub_Type_Access : Entity_Id;
RPC_Receiver : Node_Id;
Declarations : List_Id);
-- Same thing 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;
Declarations : 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,
Declarations);
Add_RACW_Read_Attribute (
RACW_Type,
Stub_Type,
Stub_Type_Access,
Declarations);
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;
Declarations : List_Id)
is
Proc_Decl : Node_Id;
Attr_Decl : Node_Id;
Body_Node : Node_Id;
Decls : List_Id;
Statements : List_Id;
Local_Statements : List_Id;
Remote_Statements : List_Id;
-- Various parts of the procedure
Procedure_Name : constant Name_Id :=
New_Internal_Name ('R');
Source_Partition : constant Entity_Id :=
Make_Defining_Identifier
(Loc, New_Internal_Name ('P'));
Source_Receiver : constant Entity_Id :=
Make_Defining_Identifier
(Loc, New_Internal_Name ('S'));
Source_Address : constant Entity_Id :=
Make_Defining_Identifier
(Loc, New_Internal_Name ('P'));
Local_Stub : constant Entity_Id :=
Make_Defining_Identifier
(Loc, New_Internal_Name ('L'));
Stubbed_Result : constant Entity_Id :=
Make_Defining_Identifier
(Loc, New_Internal_Name ('S'));
Asynchronous_Flag : constant Entity_Id :=
Asynchronous_Flags_Table.Get (RACW_Type);
pragma Assert (Present (Asynchronous_Flag));
-- Start of processing for Add_RACW_Read_Attribute
begin
-- 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
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
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 => New_List (
Make_Assignment_Statement (Loc,
Name => Result,
Expression => Make_Null (Loc)),
Make_Return_Statement (Loc))));
-- 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));
Build_Stream_Procedure
(Loc, RACW_Type, Body_Node,
Make_Defining_Identifier (Loc, Procedure_Name),
Statements, Outp => True);
Set_Declarations (Body_Node, Decls);
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);
Append_To (Declarations, 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;
Declarations : List_Id)
is
Body_Node : Node_Id;
Proc_Decl : Node_Id;
Attr_Decl : Node_Id;
Statements : List_Id;
Local_Statements : List_Id;
Remote_Statements : List_Id;
Null_Statements : List_Id;
Procedure_Name : constant Name_Id := New_Internal_Name ('R');
begin
-- 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)));
Statements := New_List (
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));
Build_Stream_Procedure
(Loc, RACW_Type, Body_Node,
Make_Defining_Identifier (Loc, Procedure_Name),
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);
Append_To (Declarations, Body_Node);
end Add_RACW_Write_Attribute;
------------------------
-- Add_RAS_Access_TSS --
------------------------
procedure Add_RAS_Access_TSS (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Ras_Type : constant Entity_Id := Defining_Identifier (N);
Fat_Type : constant Entity_Id := Equivalent_Type (Ras_Type);
-- Ras_Type is the access to subprogram type while Fat_Type is the
-- corresponding record type.
RACW_Type : constant Entity_Id :=
Underlying_RACW_Type (Ras_Type);
Desig : constant Entity_Id :=
Etype (Designated_Type (RACW_Type));
Stub_Elements : constant Stub_Structure :=
Stubs_Table.Get (Desig);
pragma Assert (Stub_Elements /= Empty_Stub_Structure);
Proc : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Chars => Make_TSS_Name (Ras_Type, TSS_RAS_Access));
Proc_Spec : Node_Id;
-- Formal parameters
Package_Name : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Chars => Name_P);
-- Target package
Subp_Id : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Chars => Name_S);
-- Target subprogram
Asynch_P : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Chars => Name_Asynchronous);
-- Is the procedure to which the 'Access applies asynchronous?
All_Calls_Remote : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Chars => Name_All_Calls_Remote);
-- True if an All_Calls_Remote pragma applies to the RCI unit
-- that contains the subprogram.
-- Common local variables
Proc_Decls : List_Id;
Proc_Statements : List_Id;
Origin : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('P'));
-- Additional local variables for the local case
Proxy_Addr : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('P'));
-- Additional local variables for the remote case
Local_Stub : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('L'));
Stub_Ptr : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('S'));
function Set_Field
(Field_Name : Name_Id;
Value : Node_Id) return Node_Id;
-- Construct an assignment that sets the named component in the
-- returned record
---------------
-- Set_Field --
---------------
function Set_Field
(Field_Name : Name_Id;
Value : Node_Id) return Node_Id
is
begin
return
Make_Assignment_Statement (Loc,
Name =>
Make_Selected_Component (Loc,
Prefix => Stub_Ptr,
Selector_Name => Field_Name),
Expression => Value);
end Set_Field;
-- Start of processing for Add_RAS_Access_TSS
begin
Proc_Decls := New_List (
-- Common declarations
Make_Object_Declaration (Loc,
Defining_Identifier => Origin,
Constant_Present => True,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
Expression =>
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Get_Active_Partition_Id), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Package_Name, Loc)))),
-- Declaration use only in the local case: proxy address
Make_Object_Declaration (Loc,
Defining_Identifier => Proxy_Addr,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
-- Declarations used only in the remote case: stub object and
-- stub pointer.
Make_Object_Declaration (Loc,
Defining_Identifier => Local_Stub,
Aliased_Present => True,
Object_Definition =>
New_Occurrence_Of (Stub_Elements.Stub_Type, Loc)),
Make_Object_Declaration (Loc,
Defining_Identifier =>
Stub_Ptr,
Object_Definition =>
New_Occurrence_Of (Stub_Elements.Stub_Type_Access, Loc),
Expression =>
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Local_Stub, Loc),
Attribute_Name => Name_Unchecked_Access)));
Set_Etype (Stub_Ptr, Stub_Elements.Stub_Type_Access);
-- Build_Get_Unique_RP_Call needs this 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_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.
-- 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,
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_Return_Statement (Loc,
Expression =>
Unchecked_Convert_To (Fat_Type,
New_Occurrence_Of (Stub_Ptr, Loc))));
Proc_Spec :=
Make_Function_Specification (Loc,
Defining_Unit_Name => Proc,
Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier => Package_Name,
Parameter_Type =>
New_Occurrence_Of (Standard_String, Loc)),
Make_Parameter_Specification (Loc,
Defining_Identifier => Subp_Id,
Parameter_Type =>
New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc)),
Make_Parameter_Specification (Loc,
Defining_Identifier => Asynch_P,
Parameter_Type =>
New_Occurrence_Of (Standard_Boolean, Loc)),
Make_Parameter_Specification (Loc,
Defining_Identifier => All_Calls_Remote,
Parameter_Type =>
New_Occurrence_Of (Standard_Boolean, Loc))),
Result_Definition =>
New_Occurrence_Of (Fat_Type, Loc));
-- Set the kind and return type of the function to prevent
-- ambiguities between Ras_Type and Fat_Type in subsequent analysis.
Set_Ekind (Proc, E_Function);
Set_Etype (Proc, Fat_Type);
Discard_Node (
Make_Subprogram_Body (Loc,
Specification => Proc_Spec,
Declarations => Proc_Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Proc_Statements)));
Set_TSS (Fat_Type, Proc);
end Add_RAS_Access_TSS;
-----------------------
-- Add_RAST_Features --
-----------------------
procedure Add_RAST_Features
(Vis_Decl : Node_Id;
RAS_Type : Entity_Id)
is
pragma Warnings (Off);
pragma Unreferenced (RAS_Type);
pragma Warnings (On);
begin
Add_RAS_Access_TSS (Vis_Decl);
end Add_RAST_Features;
-----------------------------------------
-- Add_Receiving_Stubs_To_Declarations --
-----------------------------------------
procedure Add_Receiving_Stubs_To_Declarations
(Pkg_Spec : Node_Id;
Decls : List_Id)
is
Loc : constant Source_Ptr := Sloc (Pkg_Spec);
Request_Parameter : Node_Id;
Pkg_RPC_Receiver : constant Entity_Id :=
Make_Defining_Identifier (Loc,
New_Internal_Name ('H'));
Pkg_RPC_Receiver_Statements : List_Id;
Pkg_RPC_Receiver_Cases : constant List_Id := New_List;
Pkg_RPC_Receiver_Body : Node_Id;
-- A Pkg_RPC_Receiver is built to decode the request
Lookup_RAS_Info : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('R'));
-- A remote subprogram is created to allow peers to look up
-- RAS information using subprogram ids.
Subp_Id : Entity_Id;
Subp_Index : Entity_Id;
-- Subprogram_Id as read from the incoming stream
Current_Declaration : Node_Id;
Current_Subprogram_Number : Int := First_RCI_Subprogram_Id;
Current_Stubs : Node_Id;
Subp_Info_Array : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('I'));
Subp_Info_List : constant List_Id := New_List;
Register_Pkg_Actuals : constant List_Id := New_List;
All_Calls_Remote_E : Entity_Id;
Proxy_Object_Addr : Entity_Id;
procedure Append_Stubs_To
(RPC_Receiver_Cases : List_Id;
Stubs : Node_Id;
Subprogram_Number : Int);
-- Add one case to the specified RPC receiver case list
-- associating Subprogram_Number with the subprogram declared
-- by Declaration, for which we have receiving stubs in Stubs.
---------------------
-- Append_Stubs_To --
---------------------
procedure Append_Stubs_To
(RPC_Receiver_Cases : List_Id;
Stubs : Node_Id;
Subprogram_Number : Int)
is
begin
Append_To (RPC_Receiver_Cases,
Make_Case_Statement_Alternative (Loc,
Discrete_Choices =>
New_List (Make_Integer_Literal (Loc, Subprogram_Number)),
Statements =>
New_List (
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (
Defining_Entity (Stubs), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Request_Parameter, Loc))))));
end Append_Stubs_To;
-- Start of processing for Add_Receiving_Stubs_To_Declarations
begin
-- Building receiving stubs consist in several operations:
-- - a package RPC receiver must be built. This subprogram
-- will get a Subprogram_Id from the incoming stream
-- and will dispatch the call to the right subprogram
-- - a receiving stub for any subprogram visible in the package
-- spec. This stub will read all the parameters from the stream,
-- and put the result as well as the exception occurrence in the
-- output stream
-- - a dummy package with an empty spec and a body made of an
-- elaboration part, whose job is to register the receiving
-- part of this RCI package on the name server. This is done
-- by calling System.Partition_Interface.Register_Receiving_Stub
Build_RPC_Receiver_Body (
RPC_Receiver => Pkg_RPC_Receiver,
Request => Request_Parameter,
Subp_Id => Subp_Id,
Subp_Index => Subp_Index,
Stmts => Pkg_RPC_Receiver_Statements,
Decl => Pkg_RPC_Receiver_Body);
pragma Assert (Subp_Id = Subp_Index);
-- A null subp_id denotes a call through a RAS, in which case the
-- next Uint_64 element in the stream is the address of the local
-- proxy object, from which we can retrieve the actual subprogram id.
Append_To (Pkg_RPC_Receiver_Statements,
Make_Implicit_If_Statement (Pkg_Spec,
Condition =>
Make_Op_Eq (Loc,
New_Occurrence_Of (Subp_Id, Loc),
Make_Integer_Literal (Loc, 0)),
Then_Statements => New_List (
Make_Assignment_Statement (Loc,
Name =>
New_Occurrence_Of (Subp_Id, Loc),
Expression =>
Make_Selected_Component (Loc,
Prefix =>
Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access),
OK_Convert_To (RTE (RE_Address),
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
Attribute_Name =>
Name_Input,
Expressions => New_List (
Make_Selected_Component (Loc,
Prefix => Request_Parameter,
Selector_Name => Name_Params))))),
Selector_Name =>
Make_Identifier (Loc, Name_Subp_Id))))));
-- Build a subprogram for RAS information lookups
Current_Declaration :=
Make_Subprogram_Declaration (Loc,
Specification =>
Make_Function_Specification (Loc,
Defining_Unit_Name =>
Lookup_RAS_Info,
Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_Subp_Id),
In_Present =>
True,
Parameter_Type =>
New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc))),
Result_Definition =>
New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)));
Append_To (Decls, Current_Declaration);
Analyze (Current_Declaration);
Current_Stubs := Build_Subprogram_Receiving_Stubs
(Vis_Decl => Current_Declaration,
Asynchronous => False);
Append_To (Decls, Current_Stubs);
Analyze (Current_Stubs);
Append_Stubs_To (Pkg_RPC_Receiver_Cases,
Stubs =>
Current_Stubs,
Subprogram_Number => 1);
-- For each subprogram, the receiving stub will be built and a
-- case statement will be made on the Subprogram_Id to dispatch
-- to the right subprogram.
All_Calls_Remote_E := Boolean_Literals (
Has_All_Calls_Remote (Defining_Entity (Pkg_Spec)));
Overload_Counter_Table.Reset;
Current_Declaration := First (Visible_Declarations (Pkg_Spec));
while Present (Current_Declaration) loop
if Nkind (Current_Declaration) = N_Subprogram_Declaration
and then Comes_From_Source (Current_Declaration)
then
declare
Loc : constant Source_Ptr :=
Sloc (Current_Declaration);
-- While specifically processing Current_Declaration, use
-- its Sloc as the location of all generated nodes.
Subp_Def : constant Entity_Id :=
Defining_Unit_Name
(Specification (Current_Declaration));
Subp_Val : String_Id;
begin
pragma Assert (Current_Subprogram_Number =
Get_Subprogram_Id (Subp_Def));
-- Build receiving stub
Current_Stubs :=
Build_Subprogram_Receiving_Stubs
(Vis_Decl => Current_Declaration,
Asynchronous =>
Nkind (Specification (Current_Declaration)) =
N_Procedure_Specification
and then Is_Asynchronous (Subp_Def));
Append_To (Decls, Current_Stubs);
Analyze (Current_Stubs);
-- Build RAS proxy
Add_RAS_Proxy_And_Analyze (Decls,
Vis_Decl =>
Current_Declaration,
All_Calls_Remote_E =>
All_Calls_Remote_E,
Proxy_Object_Addr =>
Proxy_Object_Addr);
-- Compute distribution identifier
Assign_Subprogram_Identifier (
Subp_Def,
Current_Subprogram_Number,
Subp_Val);
-- Add subprogram descriptor (RCI_Subp_Info) to the
-- subprograms table for this receiver. The aggregate
-- below must be kept consistent with the declaration
-- of type RCI_Subp_Info in System.Partition_Interface.
Append_To (Subp_Info_List,
Make_Component_Association (Loc,
Choices => New_List (
Make_Integer_Literal (Loc,
Current_Subprogram_Number)),
Expression =>
Make_Aggregate (Loc,
Component_Associations => New_List (
Make_Component_Association (Loc,
Choices => New_List (
Make_Identifier (Loc, Name_Addr)),
Expression =>
New_Occurrence_Of (
Proxy_Object_Addr, Loc))))));
Append_Stubs_To (Pkg_RPC_Receiver_Cases,
Stubs =>
Current_Stubs,
Subprogram_Number =>
Current_Subprogram_Number);
end;
Current_Subprogram_Number := Current_Subprogram_Number + 1;
end if;
Next (Current_Declaration);
end loop;
-- If we receive an invalid Subprogram_Id, it is best to do nothing
-- rather than raising an exception since we do not want someone
-- to crash a remote partition by sending invalid subprogram ids.
-- This is consistent with the other parts of the case statement
-- since even in presence of incorrect parameters in the stream,
-- every exception will be caught and (if the subprogram is not an
-- APC) put into the result stream and sent away.
Append_To (Pkg_RPC_Receiver_Cases,
Make_Case_Statement_Alternative (Loc,
Discrete_Choices =>
New_List (Make_Others_Choice (Loc)),
Statements =>
New_List (Make_Null_Statement (Loc))));
Append_To (Pkg_RPC_Receiver_Statements,
Make_Case_Statement (Loc,
Expression =>
New_Occurrence_Of (Subp_Id, Loc),
Alternatives => Pkg_RPC_Receiver_Cases));
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => Subp_Info_Array,
Constant_Present => True,
Aliased_Present => True,
Object_Definition =>
Make_Subtype_Indication (Loc,
Subtype_Mark =>
New_Occurrence_Of (RTE (RE_RCI_Subp_Info_Array), Loc),
Constraint =>
Make_Index_Or_Discriminant_Constraint (Loc,
New_List (
Make_Range (Loc,
Low_Bound => Make_Integer_Literal (Loc,
First_RCI_Subprogram_Id),
High_Bound =>
Make_Integer_Literal (Loc,
First_RCI_Subprogram_Id
+ List_Length (Subp_Info_List) - 1))))),
Expression =>
Make_Aggregate (Loc,
Component_Associations => Subp_Info_List)));
Analyze (Last (Decls));
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_Return_Statement (Loc,
Expression => OK_Convert_To (RTE (RE_Unsigned_64),
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))))))));
Analyze (Last (Decls));
Append_To (Decls, Pkg_RPC_Receiver_Body);
Analyze (Last (Decls));
Get_Library_Unit_Name_String (Pkg_Spec);
Append_To (Register_Pkg_Actuals,
-- Name
Make_String_Literal (Loc,
Strval => String_From_Name_Buffer));
Append_To (Register_Pkg_Actuals,
-- Receiver
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Pkg_RPC_Receiver, Loc),
Attribute_Name =>
Name_Unrestricted_Access));
Append_To (Register_Pkg_Actuals,
-- Version
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc),
Attribute_Name =>
Name_Version));
Append_To (Register_Pkg_Actuals,
-- Subp_Info
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Subp_Info_Array, Loc),
Attribute_Name =>
Name_Address));
Append_To (Register_Pkg_Actuals,
-- Subp_Info_Len
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Subp_Info_Array, Loc),
Attribute_Name =>
Name_Length));
Append_To (Decls,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Register_Receiving_Stub), Loc),
Parameter_Associations => Register_Pkg_Actuals));
Analyze (Last (Decls));
end Add_Receiving_Stubs_To_Declarations;
---------------------------------
-- Build_General_Calling_Stubs --
---------------------------------
procedure Build_General_Calling_Stubs
(Decls : List_Id;
Statements : List_Id;
Target_Partition : Entity_Id;
Target_RPC_Receiver : Node_Id;
Subprogram_Id : Node_Id;
Asynchronous : Node_Id := Empty;
Is_Known_Asynchronous : Boolean := False;
Is_Known_Non_Asynchronous : Boolean := False;
Is_Function : Boolean;
Spec : Node_Id;
Stub_Type : Entity_Id := Empty;
RACW_Type : Entity_Id := Empty;
Nod : Node_Id)
is
Loc : constant Source_Ptr := Sloc (Nod);
Stream_Parameter : Node_Id;
-- Name of the stream used to transmit parameters to the
-- remote package.
Result_Parameter : Node_Id;
-- Name of the result parameter (in non-APC cases) which get the
-- result of the remote subprogram.
Exception_Return_Parameter : Node_Id;
-- Name of the parameter which will hold the exception sent by the
-- remote subprogram.
Current_Parameter : Node_Id;
-- Current parameter being handled
Ordered_Parameters_List : constant List_Id :=
Build_Ordered_Parameters_List (Spec);
Asynchronous_Statements : List_Id := No_List;
Non_Asynchronous_Statements : List_Id := No_List;
-- Statements specifics to the Asynchronous/Non-Asynchronous cases
Extra_Formal_Statements : constant List_Id := New_List;
-- List of statements for extra formal parameters. It will appear
-- after the regular statements for writing out parameters.
pragma Warnings (Off);
pragma Unreferenced (RACW_Type);
-- Used only for the PolyORB case
pragma Warnings (On);
begin
-- The general form of a calling stub for a given subprogram is:
-- procedure X (...) is P : constant Partition_ID :=
-- RCI_Cache.Get_Active_Partition_ID; Stream, Result : aliased
-- System.RPC.Params_Stream_Type (0); begin
-- Put_Package_RPC_Receiver_In_Stream; (the package RPC receiver
-- comes from RCI_Cache.Get_RCI_Package_Receiver)
-- Put_Subprogram_Id_In_Stream; Put_Parameters_In_Stream; Do_RPC
-- (Stream, Result); Read_Exception_Occurrence_From_Result;
-- Raise_It;
-- Read_Out_Parameters_And_Function_Return_From_Stream; end X;
-- There are some variations: Do_APC is called for an asynchronous
-- procedure and the part after the call is completely ommitted as
-- well as the declaration of Result. For a function call, 'Input is
-- always used to read the result even if it is constrained.
Stream_Parameter :=
Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => Stream_Parameter,
Aliased_Present => True,
Object_Definition =>
Make_Subtype_Indication (Loc,
Subtype_Mark =>
New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc),
Constraint =>
Make_Index_Or_Discriminant_Constraint (Loc,
Constraints =>
New_List (Make_Integer_Literal (Loc, 0))))));
if not Is_Known_Asynchronous then
Result_Parameter :=
Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => Result_Parameter,
Aliased_Present => True,
Object_Definition =>
Make_Subtype_Indication (Loc,
Subtype_Mark =>
New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc),
Constraint =>
Make_Index_Or_Discriminant_Constraint (Loc,
Constraints =>
New_List (Make_Integer_Literal (Loc, 0))))));
Exception_Return_Parameter :=
Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => Exception_Return_Parameter,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc)));
else
Result_Parameter := Empty;
Exception_Return_Parameter := Empty;
end if;
-- Put first the RPC receiver corresponding to the remote package
Append_To (Statements,
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
Attribute_Name => Name_Write,
Expressions => New_List (
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Stream_Parameter, Loc),
Attribute_Name =>
Name_Access),
Target_RPC_Receiver)));
-- Then put the Subprogram_Id of the subprogram we want to call in
-- the stream.
Append_To (Statements,
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
Attribute_Name =>
Name_Write,
Expressions => New_List (
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Stream_Parameter, Loc),
Attribute_Name => Name_Access),
Subprogram_Id)));
Current_Parameter := First (Ordered_Parameters_List);
while Present (Current_Parameter) loop
declare
Typ : constant Node_Id :=
Parameter_Type (Current_Parameter);
Etyp : Entity_Id;
Constrained : Boolean;
Value : Node_Id;
Extra_Parameter : Entity_Id;
begin
if Is_RACW_Controlling_Formal
(Current_Parameter, Stub_Type)
then
-- In the case of a controlling formal argument, we marshall
-- its addr field rather than the local stub.
Append_To (Statements,
Pack_Node_Into_Stream (Loc,
Stream => Stream_Parameter,
Object =>
Make_Selected_Component (Loc,
Prefix =>
Defining_Identifier (Current_Parameter),
Selector_Name => Name_Addr),
Etyp => RTE (RE_Unsigned_64)));
else
Value := New_Occurrence_Of
(Defining_Identifier (Current_Parameter), Loc);
-- Access type parameters are transmitted as in out
-- parameters. However, a dereference is needed so that
-- we marshall the designated object.
if Nkind (Typ) = N_Access_Definition then
Value := Make_Explicit_Dereference (Loc, Value);
Etyp := Etype (Subtype_Mark (Typ));
else
Etyp := Etype (Typ);
end if;
Constrained :=
Is_Constrained (Etyp) or else Is_Elementary_Type (Etyp);
-- Any parameter but unconstrained out parameters are
-- transmitted to the peer.
if In_Present (Current_Parameter)
or else not Out_Present (Current_Parameter)
or else not Constrained
then
Append_To (Statements,
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Etyp, Loc),
Attribute_Name =>
Output_From_Constrained (Constrained),
Expressions => New_List (
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Stream_Parameter, Loc),
Attribute_Name => Name_Access),
Value)));
end if;
end if;
-- If the current parameter has a dynamic constrained status,
-- then this status is transmitted as well.
-- This should be done for accessibility as well ???
if Nkind (Typ) /= N_Access_Definition
and then Need_Extra_Constrained (Current_Parameter)
then
-- In this block, we do not use the extra formal that has
-- been created because it does not exist at the time of
-- expansion when building calling stubs for remote access
-- to subprogram types. We create an extra variable of this
-- type and push it in the stream after the regular
-- parameters.
Extra_Parameter := Make_Defining_Identifier
(Loc, New_Internal_Name ('P'));
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => Extra_Parameter,
Constant_Present => True,
Object_Definition =>
New_Occurrence_Of (Standard_Boolean, Loc),
Expression =>
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (
Defining_Identifier (Current_Parameter), Loc),
Attribute_Name => Name_Constrained)));
Append_To (Extra_Formal_Statements,
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Standard_Boolean, Loc),
Attribute_Name =>
Name_Write,
Expressions => New_List (
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Stream_Parameter, Loc),
Attribute_Name =>
Name_Access),
New_Occurrence_Of (Extra_Parameter, Loc))));
end if;
Next (Current_Parameter);
end;
end loop;
-- Append the formal statements list to the statements
Append_List_To (Statements, Extra_Formal_Statements);
if not Is_Known_Non_Asynchronous then
-- Build the call to System.RPC.Do_APC
Asynchronous_Statements := New_List (
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Do_Apc), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Target_Partition, Loc),
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Stream_Parameter, Loc),
Attribute_Name =>
Name_Access))));
else
Asynchronous_Statements := No_List;
end if;
if not Is_Known_Asynchronous then
-- Build the call to System.RPC.Do_RPC
Non_Asynchronous_Statements := New_List (
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Do_Rpc), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Target_Partition, Loc),
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Stream_Parameter, Loc),
Attribute_Name =>
Name_Access),
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Result_Parameter, Loc),
Attribute_Name =>
Name_Access))));
-- Read the exception occurrence from the result stream and
-- reraise it. It does no harm if this is a Null_Occurrence since
-- this does nothing.
Append_To (Non_Asynchronous_Statements,
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc),
Attribute_Name =>
Name_Read,
Expressions => New_List (
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Result_Parameter, Loc),
Attribute_Name =>
Name_Access),
New_Occurrence_Of (Exception_Return_Parameter, Loc))));
Append_To (Non_Asynchronous_Statements,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Reraise_Occurrence), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Exception_Return_Parameter, Loc))));
if Is_Function then
-- If this is a function call, then read the value and return
-- it. The return value is written/read using 'Output/'Input.
Append_To (Non_Asynchronous_Statements,
Make_Tag_Check (Loc,
Make_Return_Statement (Loc,
Expression =>
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (
Etype (Result_Definition (Spec)), Loc),
Attribute_Name => Name_Input,
Expressions => New_List (
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Result_Parameter, Loc),
Attribute_Name => Name_Access))))));
else
-- Loop around parameters and assign out (or in out)
-- parameters. In the case of RACW, controlling arguments
-- cannot possibly have changed since they are remote, so we do
-- not read them from the stream.
Current_Parameter := First (Ordered_Parameters_List);
while Present (Current_Parameter) loop
declare
Typ : constant Node_Id :=
Parameter_Type (Current_Parameter);
Etyp : Entity_Id;
Value : Node_Id;
begin
Value :=
New_Occurrence_Of
(Defining_Identifier (Current_Parameter), Loc);
if Nkind (Typ) = N_Access_Definition then
Value := Make_Explicit_Dereference (Loc, Value);
Etyp := Etype (Subtype_Mark (Typ));
else
Etyp := Etype (Typ);
end if;
if (Out_Present (Current_Parameter)
or else Nkind (Typ) = N_Access_Definition)
and then Etyp /= Stub_Type
then
Append_To (Non_Asynchronous_Statements,
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Etyp, Loc),
Attribute_Name => Name_Read,
Expressions => New_List (
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Result_Parameter, Loc),
Attribute_Name =>
Name_Access),
Value)));
end if;
end;
Next (Current_Parameter);
end loop;
end if;
end if;
if Is_Known_Asynchronous then
Append_List_To (Statements, Asynchronous_Statements);
elsif Is_Known_Non_Asynchronous then
Append_List_To (Statements, Non_Asynchronous_Statements);
else
pragma Assert (Present (Asynchronous));
Prepend_To (Asynchronous_Statements,
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Standard_Boolean, Loc),
Attribute_Name => Name_Write,
Expressions => New_List (
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Stream_Parameter, Loc),
Attribute_Name => Name_Access),
New_Occurrence_Of (Standard_True, Loc))));
Prepend_To (Non_Asynchronous_Statements,
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Standard_Boolean, Loc),
Attribute_Name => Name_Write,
Expressions => New_List (
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Stream_Parameter, Loc),
Attribute_Name => Name_Access),
New_Occurrence_Of (Standard_False, Loc))));
Append_To (Statements,
Make_Implicit_If_Statement (Nod,
Condition => Asynchronous,
Then_Statements => Asynchronous_Statements,
Else_Statements => Non_Asynchronous_Statements));
end if;
end Build_General_Calling_Stubs;
-----------------------------
-- Build_RPC_Receiver_Body --
-----------------------------
procedure Build_RPC_Receiver_Body
(RPC_Receiver : Entity_Id;
Request : out Entity_Id;
Subp_Id : out Entity_Id;
Subp_Index : out Entity_Id;
Stmts : out List_Id;
Decl : out Node_Id)
is
Loc : constant Source_Ptr := Sloc (RPC_Receiver);
RPC_Receiver_Spec : Node_Id;
RPC_Receiver_Decls : List_Id;
begin
Request := Make_Defining_Identifier (Loc, Name_R);
RPC_Receiver_Spec :=
Build_RPC_Receiver_Specification
(RPC_Receiver => RPC_Receiver,
Request_Parameter => Request);
Subp_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
Subp_Index := Subp_Id;
-- Subp_Id may not be a constant, because in the case of the RPC
-- receiver for an RCI package, when a call is received from a RAS
-- dereference, it will be assigned during subsequent processing.
RPC_Receiver_Decls := New_List (
Make_Object_Declaration (Loc,
Defining_Identifier => Subp_Id,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
Expression =>
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
Attribute_Name => Name_Input,
Expressions => New_List (
Make_Selected_Component (Loc,
Prefix => Request,
Selector_Name => Name_Params)))));
Stmts := New_List;
Decl :=
Make_Subprogram_Body (Loc,
Specification => RPC_Receiver_Spec,
Declarations => RPC_Receiver_Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Stmts));
end Build_RPC_Receiver_Body;
-----------------------
-- Build_Stub_Target --
-----------------------
function Build_Stub_Target
(Loc : Source_Ptr;
Decls : List_Id;
RCI_Locator : Entity_Id;
Controlling_Parameter : Entity_Id) return RPC_Target
is
Target_Info : RPC_Target (PCS_Kind => Name_GARLIC_DSA);
begin
Target_Info.Partition :=
Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
if Present (Controlling_Parameter) then
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => Target_Info.Partition,
Constant_Present => True,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
Expression =>
Make_Selected_Component (Loc,
Prefix => Controlling_Parameter,
Selector_Name => Name_Origin)));
Target_Info.RPC_Receiver :=
Make_Selected_Component (Loc,
Prefix => Controlling_Parameter,
Selector_Name => Name_Receiver);
else
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => Target_Info.Partition,
Constant_Present => True,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
Expression =>
Make_Function_Call (Loc,
Name => Make_Selected_Component (Loc,
Prefix =>
Make_Identifier (Loc, Chars (RCI_Locator)),
Selector_Name =>
Make_Identifier (Loc,
Name_Get_Active_Partition_ID)))));
Target_Info.RPC_Receiver :=
Make_Selected_Component (Loc,
Prefix =>
Make_Identifier (Loc, Chars (RCI_Locator)),
Selector_Name =>
Make_Identifier (Loc, Name_Get_RCI_Package_Receiver));
end if;
return Target_Info;
end Build_Stub_Target;
---------------------
-- Build_Stub_Type --
---------------------
procedure Build_Stub_Type
(RACW_Type : Entity_Id;
Stub_Type : Entity_Id;
Stub_Type_Decl : out Node_Id;
RPC_Receiver_Decl : out Node_Id)
is
Loc : constant Source_Ptr := Sloc (Stub_Type);
Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
begin
Stub_Type_Decl :=
Make_Full_Type_Declaration (Loc,
Defining_Identifier => Stub_Type,
Type_Definition =>
Make_Record_Definition (Loc,
Tagged_Present => True,
Limited_Present => True,
Component_List =>
Make_Component_List (Loc,
Component_Items => New_List (
Make_Component_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_Origin),
Component_Definition =>
Make_Component_Definition (Loc,
Aliased_Present => False,
Subtype_Indication =>
New_Occurrence_Of (
RTE (RE_Partition_ID), Loc))),
Make_Component_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_Receiver),
Component_Definition =>
Make_Component_Definition (Loc,
Aliased_Present => False,
Subtype_Indication =>
New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))),
Make_Component_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_Addr),
Component_Definition =>
Make_Component_Definition (Loc,
Aliased_Present => False,
Subtype_Indication =>
New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))),
Make_Component_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_Asynchronous),
Component_Definition =>
Make_Component_Definition (Loc,
Aliased_Present => False,
Subtype_Indication =>
New_Occurrence_Of (
Standard_Boolean, Loc)))))));
if Is_RAS then
RPC_Receiver_Decl := Empty;
else
declare
RPC_Receiver_Request : constant Entity_Id :=
Make_Defining_Identifier (Loc, Name_R);
begin
RPC_Receiver_Decl :=
Make_Subprogram_Declaration (Loc,
Build_RPC_Receiver_Specification (
RPC_Receiver => Make_Defining_Identifier (Loc,
New_Internal_Name ('R')),
Request_Parameter => RPC_Receiver_Request));
end;
end if;
end Build_Stub_Type;
--------------------------------------
-- Build_Subprogram_Receiving_Stubs --
--------------------------------------
function Build_Subprogram_Receiving_Stubs
(Vis_Decl : Node_Id;
Asynchronous : Boolean;
Dynamically_Asynchronous : Boolean := False;
Stub_Type : Entity_Id := Empty;
RACW_Type : Entity_Id := Empty;
Parent_Primitive : Entity_Id := Empty) return Node_Id
is
Loc : constant Source_Ptr := Sloc (Vis_Decl);
Request_Parameter : Node_Id;
-- ???
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;
Request_Parameter :=
Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
if Dynamically_Asynchronous then
Dynamic_Async :=
Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
else
Dynamic_Async := Empty;
end if;
if not Asynchronous or Dynamically_Asynchronous then
-- The first statement after the subprogram call is a statement to
-- writes 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;
Object : constant Entity_Id :=
Make_Defining_Identifier (Loc,
New_Internal_Name ('P'));
Expr : Node_Id := Empty;
Is_Controlling_Formal : constant Boolean :=
Is_RACW_Controlling_Formal
(Current_Parameter, Stub_Type);
begin
Set_Ekind (Object, E_Variable);
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 :=
Is_Constrained (Etyp) or else Is_Elementary_Type (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 contrained, 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 not Is_Controlling_Formal 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
Expr := Input_With_Tag_Check (Loc,
Var_Type => Etyp,
Stream => Make_Selected_Component (Loc,
Prefix => Request_Parameter,
Selector_Name => Name_Params));
Append_To (Decls, Expr);
Expr := Make_Function_Call (Loc,
New_Occurrence_Of (Defining_Unit_Name
(Specification (Expr)), Loc));
end if;
end if;
-- If we do not have to output the current parameter, then it
-- can well be flagged as constant. This may allow further
-- optimizations done by the back end.
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => Object,
Constant_Present => not Constrained
and then not Out_Present (Current_Parameter),
Object_Definition =>
New_Occurrence_Of (Etyp, Loc),
Expression => Expr));
-- 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 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)))
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))));
Set_Extra_Constrained (Object, Formal_Entity);
end;
end if;
end;
Next (Current_Parameter);
end loop;
-- Append the formal statements list at the end of regular statements
Append_List_To (Statements, Extra_Formal_Statements);
if Nkind (Specification (Vis_Decl)) = N_Function_Specification then
-- The remote subprogram is a function. We build an inner block to
-- be able to hold a potentially unconstrained result in a
-- variable.
declare
Etyp : constant Entity_Id :=
Etype (Result_Definition (Specification (Vis_Decl)));
Result : constant Node_Id :=
Make_Defining_Identifier (Loc,
New_Internal_Name ('R'));
begin
Inner_Decls := New_List (
Make_Object_Declaration (Loc,
Defining_Identifier => Result,
Constant_Present => True,
Object_Definition => New_Occurrence_Of (Etyp, Loc),
Expression =>
Make_Function_Call (Loc,
Name => Called_Subprogram,
Parameter_Associations => Parameter_List)));
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_Exception_Handler (Loc,
Exception_Choices => New_List (Make_Others_Choice (Loc)),
Statements => New_List (Make_Null_Statement (Loc))));
else
-- In the other cases, if an exception is raised, then the
-- exception occurrence is copied into the output stream and
-- no other output parameter is written.
Excep_Choice :=
Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
Excep_Code := New_List (
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc),
Attribute_Name => Name_Write,
Expressions => New_List (
Make_Selected_Component (Loc,
Prefix => Request_Parameter,
Selector_Name => Name_Result),
New_Occurrence_Of (Excep_Choice, Loc))));
if Dynamically_Asynchronous then
Excep_Code := New_List (
Make_Implicit_If_Statement (Vis_Decl,
Condition => Make_Op_Not (Loc,
New_Occurrence_Of (Dynamic_Async, Loc)),
Then_Statements => Excep_Code));
end if;
Excep_Handlers := New_List (
Make_Exception_Handler (Loc,
Choice_Parameter => Excep_Choice,
Exception_Choices => New_List (Make_Others_Choice (Loc)),
Statements => Excep_Code));
end if;
Subp_Spec :=
Make_Procedure_Specification (Loc,
Defining_Unit_Name =>
Make_Defining_Identifier (Loc, New_Internal_Name ('F')),
Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier => Request_Parameter,
Parameter_Type =>
New_Occurrence_Of (RTE (RE_Request_Access), Loc))));
return
Make_Subprogram_Body (Loc,
Specification => Subp_Spec,
Declarations => Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Statements,
Exception_Handlers => Excep_Handlers));
end Build_Subprogram_Receiving_Stubs;
------------
-- Result --
------------
function Result return Node_Id is
begin
return Make_Identifier (Loc, Name_V);
end Result;
----------------------
-- Stream_Parameter --
----------------------
function Stream_Parameter return Node_Id is
begin
return Make_Identifier (Loc, Name_S);
end Stream_Parameter;
end GARLIC_Support;
-----------------------------
-- 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;
-----------------------
-- Get_Subprogram_Id --
-----------------------
function Get_Subprogram_Id (Def : Entity_Id) return String_Id is
begin
return Get_Subprogram_Ids (Def).Str_Identifier;
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
Result : Subprogram_Identifiers :=
Subprogram_Identifier_Table.Get (Def);
Current_Declaration : Node_Id;
Current_Subp : Entity_Id;
Current_Subp_Str : String_Id;
Current_Subp_Number : Int := First_RCI_Subprogram_Id;
begin
if Result.Str_Identifier = No_String then
-- We are looking up this subprogram's identifier 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 (Def))
and then
(Nkind (Parent (Def)) = N_Procedure_Specification
or else
Nkind (Parent (Def)) = N_Function_Specification));
Current_Declaration :=
First (Visible_Declarations
(Package_Specification_Of_Scope (Scope (Def))));
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);
if Current_Subp = Def then
Result := (Current_Subp_Str, Current_Subp_Number);
end if;
Current_Subp_Number := Current_Subp_Number + 1;
end if;
Next (Current_Declaration);
end loop;
end if;
pragma Assert (Result.Str_Identifier /= No_String);
return Result;
end Get_Subprogram_Ids;
----------
-- Hash --
----------
function Hash (F : Entity_Id) return Hash_Index is
begin
return Hash_Index (Natural (F) mod Positive (Hash_Index'Last + 1));
end Hash;
function Hash (F : Name_Id) return Hash_Index is
begin
return Hash_Index (Natural (F) mod Positive (Hash_Index'Last + 1));
end Hash;
--------------------------
-- Input_With_Tag_Check --
--------------------------
function Input_With_Tag_Check
(Loc : Source_Ptr;
Var_Type : Entity_Id;
Stream : Node_Id) return Node_Id
is
begin
return
Make_Subprogram_Body (Loc,
Specification => Make_Function_Specification (Loc,
Defining_Unit_Name =>
Make_Defining_Identifier (Loc, New_Internal_Name ('S')),
Result_Definition => New_Occurrence_Of (Var_Type, Loc)),
Declarations => No_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc, New_List (
Make_Tag_Check (Loc,
Make_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_Tag_Check --
--------------------
function Make_Tag_Check (Loc : Source_Ptr; N : Node_Id) return Node_Id is
Occ : constant Entity_Id :=
Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
begin
return Make_Block_Statement (Loc,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (N),
Exception_Handlers => New_List (
Make_Exception_Handler (Loc,
Choice_Parameter => Occ,
Exception_Choices =>
New_List (New_Occurrence_Of (RTE (RE_Tag_Error), Loc)),
Statements =>
New_List (Make_Procedure_Call_Statement (Loc,
New_Occurrence_Of
(RTE (RE_Raise_Program_Error_Unknown_Tag), Loc),
New_List (New_Occurrence_Of (Occ, Loc))))))));
end Make_Tag_Check;
----------------------------
-- Need_Extra_Constrained --
----------------------------
function Need_Extra_Constrained (Parameter : Node_Id) return Boolean is
Etyp : constant Entity_Id := Etype (Parameter_Type (Parameter));
begin
return Out_Present (Parameter)
and then Has_Discriminants (Etyp)
and then not Is_Constrained (Etyp)
and then not Is_Indefinite_Subtype (Etyp);
end Need_Extra_Constrained;
------------------------------------
-- Pack_Entity_Into_Stream_Access --
------------------------------------
function Pack_Entity_Into_Stream_Access
(Loc : Source_Ptr;
Stream : Node_Id;
Object : Entity_Id;
Etyp : Entity_Id := Empty) return Node_Id
is
Typ : Entity_Id;
begin
if Present (Etyp) then
Typ := Etyp;
else
Typ := Etype (Object);
end if;
return
Pack_Node_Into_Stream_Access (Loc,
Stream => Stream,
Object => New_Occurrence_Of (Object, Loc),
Etyp => Typ);
end Pack_Entity_Into_Stream_Access;
---------------------------
-- Pack_Node_Into_Stream --
---------------------------
function Pack_Node_Into_Stream
(Loc : Source_Ptr;
Stream : Entity_Id;
Object : Node_Id;
Etyp : Entity_Id) return Node_Id
is
Write_Attribute : Name_Id := Name_Write;
begin
if not Is_Constrained (Etyp) then
Write_Attribute := Name_Output;
end if;
return
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Etyp, Loc),
Attribute_Name => Write_Attribute,
Expressions => New_List (
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Stream, Loc),
Attribute_Name => Name_Access),
Object));
end Pack_Node_Into_Stream;
----------------------------------
-- Pack_Node_Into_Stream_Access --
----------------------------------
function Pack_Node_Into_Stream_Access
(Loc : Source_Ptr;
Stream : Node_Id;
Object : Node_Id;
Etyp : Entity_Id) return Node_Id
is
Write_Attribute : Name_Id := Name_Write;
begin
if not Is_Constrained (Etyp) then
Write_Attribute := Name_Output;
end if;
return
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Etyp, Loc),
Attribute_Name => Write_Attribute,
Expressions => New_List (
Stream,
Object));
end Pack_Node_Into_Stream_Access;
---------------------
-- PolyORB_Support --
---------------------
package body PolyORB_Support is
-- Local subprograms
procedure Add_RACW_Read_Attribute
(RACW_Type : Entity_Id;
Stub_Type : Entity_Id;
Stub_Type_Access : Entity_Id;
Declarations : List_Id);
-- Add Read attribute in Decls for the RACW type. The Read attribute
-- is added right after the RACW_Type declaration while the body is
-- inserted after Declarations.
procedure Add_RACW_Write_Attribute
(RACW_Type : Entity_Id;
Stub_Type : Entity_Id;
Stub_Type_Access : Entity_Id;
Declarations : List_Id);
-- Same thing for the Write attribute
procedure Add_RACW_From_Any
(RACW_Type : Entity_Id;
Stub_Type : Entity_Id;
Stub_Type_Access : Entity_Id;
Declarations : List_Id);
-- Add the From_Any TSS for this RACW type
procedure Add_RACW_To_Any
(Designated_Type : Entity_Id;
RACW_Type : Entity_Id;
Stub_Type : Entity_Id;
Stub_Type_Access : Entity_Id;
Declarations : List_Id);
-- Add the To_Any TSS for this RACW type
procedure Add_RACW_TypeCode
(Designated_Type : Entity_Id;
RACW_Type : Entity_Id;
Declarations : List_Id);
-- Add the TypeCode TSS for this RACW type
procedure Add_RAS_From_Any (RAS_Type : Entity_Id);
-- Add the From_Any TSS for this RAS type
procedure Add_RAS_To_Any (RAS_Type : Entity_Id);
-- Add the To_Any TSS for this RAS type
procedure Add_RAS_TypeCode (RAS_Type : Entity_Id);
-- Add the TypeCode TSS for this RAS type
procedure Add_RAS_Access_TSS (N : Node_Id);
-- Add a subprogram body for RAS Access TSS
-------------------------------------
-- Add_Obj_RPC_Receiver_Completion --
-------------------------------------
procedure Add_Obj_RPC_Receiver_Completion
(Loc : Source_Ptr;
Decls : List_Id;
RPC_Receiver : Entity_Id;
Stub_Elements : Stub_Structure)
is
Desig : constant Entity_Id :=
Etype (Designated_Type (Stub_Elements.RACW_Type));
begin
Append_To (Decls,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (
RTE (RE_Register_Obj_Receiving_Stub), Loc),
Parameter_Associations => New_List (
-- Name
Make_String_Literal (Loc,
Full_Qualified_Name (Desig)),
-- Handler
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (
Defining_Unit_Name (Parent (RPC_Receiver)), Loc),
Attribute_Name =>
Name_Access),
-- Receiver
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (
Defining_Identifier (
Stub_Elements.RPC_Receiver_Decl), Loc),
Attribute_Name =>
Name_Access))));
end Add_Obj_RPC_Receiver_Completion;
-----------------------
-- Add_RACW_Features --
-----------------------
procedure Add_RACW_Features
(RACW_Type : Entity_Id;
Desig : Entity_Id;
Stub_Type : Entity_Id;
Stub_Type_Access : Entity_Id;
RPC_Receiver_Decl : Node_Id;
Declarations : List_Id)
is
pragma Warnings (Off);
pragma Unreferenced (RPC_Receiver_Decl);
pragma Warnings (On);
begin
Add_RACW_From_Any
(RACW_Type => RACW_Type,
Stub_Type => Stub_Type,
Stub_Type_Access => Stub_Type_Access,
Declarations => Declarations);
Add_RACW_To_Any
(Designated_Type => Desig,
RACW_Type => RACW_Type,
Stub_Type => Stub_Type,
Stub_Type_Access => Stub_Type_Access,
Declarations => Declarations);
-- In the PolyORB case, the RACW 'Read and 'Write attributes
-- are implemented in terms of the From_Any and To_Any TSSs,
-- so these TSSs must be expanded before 'Read and 'Write.
Add_RACW_Write_Attribute
(RACW_Type => RACW_Type,
Stub_Type => Stub_Type,
Stub_Type_Access => Stub_Type_Access,
Declarations => Declarations);
Add_RACW_Read_Attribute
(RACW_Type => RACW_Type,
Stub_Type => Stub_Type,
Stub_Type_Access => Stub_Type_Access,
Declarations => Declarations);
Add_RACW_TypeCode
(Designated_Type => Desig,
RACW_Type => RACW_Type,
Declarations => Declarations);
end Add_RACW_Features;
-----------------------
-- Add_RACW_From_Any --
-----------------------
procedure Add_RACW_From_Any
(RACW_Type : Entity_Id;
Stub_Type : Entity_Id;
Stub_Type_Access : Entity_Id;
Declarations : 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, New_Internal_Name ('F'));
Func_Spec : Node_Id;
Func_Decl : Node_Id;
Func_Body : Node_Id;
Decls : List_Id;
Statements : List_Id;
Stub_Statements : List_Id;
Local_Statements : List_Id;
-- Various parts of the subprogram
Any_Parameter : constant Entity_Id :=
Make_Defining_Identifier (Loc, Name_A);
Reference : constant Entity_Id :=
Make_Defining_Identifier
(Loc, New_Internal_Name ('R'));
Is_Local : constant Entity_Id :=
Make_Defining_Identifier
(Loc, New_Internal_Name ('L'));
Addr : constant Entity_Id :=
Make_Defining_Identifier
(Loc, New_Internal_Name ('A'));
Local_Stub : constant Entity_Id :=
Make_Defining_Identifier
(Loc, New_Internal_Name ('L'));
Stubbed_Result : constant Entity_Id :=
Make_Defining_Identifier
(Loc, New_Internal_Name ('S'));
Stub_Condition : Node_Id;
-- An expression that determines whether we create a stub for the
-- newly-unpacked RACW. Normally we create a stub only for remote
-- objects, but in the case of an RACW used to implement a RAS,
-- we also create a stub for local subprograms if a pragma
-- All_Calls_Remote applies.
Asynchronous_Flag : constant Entity_Id :=
Asynchronous_Flags_Table.Get (RACW_Type);
-- The flag object declared in Add_RACW_Asynchronous_Flag
begin
-- Object declarations
Decls := New_List (
Make_Object_Declaration (Loc,
Defining_Identifier =>
Reference,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Object_Ref), Loc),
Expression =>
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of (RTE (RE_FA_ObjRef), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Any_Parameter, 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)),
Make_Object_Declaration (Loc,
Defining_Identifier => Is_Local,
Object_Definition =>
New_Occurrence_Of (Standard_Boolean, Loc)),
Make_Object_Declaration (Loc,
Defining_Identifier => Addr,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Address), Loc)));
-- Build_Get_Unique_RP_Call needs the type of Stubbed_Result
Set_Etype (Stubbed_Result, Stub_Type_Access);
-- If the ref Is_Nil, return a null pointer
Statements := New_List (
Make_Implicit_If_Statement (RACW_Type,
Condition =>
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Is_Nil), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Reference, Loc))),
Then_Statements => New_List (
Make_Return_Statement (Loc,
Expression =>
Make_Null (Loc)))));
Append_To (Statements,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Reference, Loc),
New_Occurrence_Of (Is_Local, Loc),
New_Occurrence_Of (Addr, 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. This stanza is always used in the
-- case of RAS types, for which a stub is required even for local
-- subprograms.
Stub_Statements := New_List (
Make_Assignment_Statement (Loc,
Name => Make_Selected_Component (Loc,
Prefix => Stubbed_Result,
Selector_Name => Name_Target),
Expression =>
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Entity_Of), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Reference, Loc)))),
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Inc_Usage), Loc),
Parameter_Associations => New_List (
Make_Selected_Component (Loc,
Prefix => Stubbed_Result,
Selector_Name => Name_Target))),
Make_Assignment_Statement (Loc,
Name => Make_Selected_Component (Loc,
Prefix => Stubbed_Result,
Selector_Name => Name_Asynchronous),
Expression =>
New_Occurrence_Of (Asynchronous_Flag, Loc)));
-- ??? 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.
Append_List_To (Stub_Statements,
Build_Get_Unique_RP_Call (Loc, Stubbed_Result, Stub_Type));
-- Distinguish between the local and remote cases, and execute the
-- appropriate piece of code.
Stub_Condition := New_Occurrence_Of (Is_Local, Loc);
if Is_RAS then
Stub_Condition := Make_And_Then (Loc,
Left_Opnd =>
Stub_Condition,
Right_Opnd =>
Make_Selected_Component (Loc,
Prefix =>
Unchecked_Convert_To (
RTE (RE_RAS_Proxy_Type_Access),
New_Occurrence_Of (Addr, Loc)),
Selector_Name =>
Make_Identifier (Loc,
Name_All_Calls_Remote)));
end if;
Local_Statements := New_List (
Make_Return_Statement (Loc,
Expression =>
Unchecked_Convert_To (RACW_Type,
New_Occurrence_Of (Addr, Loc))));
Append_To (Statements,
Make_Implicit_If_Statement (RACW_Type,
Condition =>
Stub_Condition,
Then_Statements => Local_Statements,
Else_Statements => Stub_Statements));
Append_To (Statements,
Make_Return_Statement (Loc,
Expression => Unchecked_Convert_To (RACW_Type,
New_Occurrence_Of (Stubbed_Result, Loc))));
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);
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));
Insert_After (Declaration_Node (RACW_Type), Func_Decl);
Append_To (Declarations, Func_Body);
Set_Renaming_TSS (RACW_Type, Fnam, TSS_From_Any);
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;
Declarations : List_Id)
is
pragma Warnings (Off);
pragma Unreferenced (Stub_Type, Stub_Type_Access);
pragma Warnings (On);
Loc : constant Source_Ptr := Sloc (RACW_Type);
Proc_Decl : Node_Id;
Attr_Decl : Node_Id;
Body_Node : Node_Id;
Decls : List_Id;
Statements : List_Id;
-- Various parts of the procedure
Procedure_Name : constant Name_Id :=
New_Internal_Name ('R');
Source_Ref : constant Entity_Id :=
Make_Defining_Identifier
(Loc, New_Internal_Name ('R'));
Asynchronous_Flag : constant Entity_Id :=
Asynchronous_Flags_Table.Get (RACW_Type);
pragma Assert (Present (Asynchronous_Flag));
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
-- Generate object declarations
Decls := New_List (
Make_Object_Declaration (Loc,
Defining_Identifier => Source_Ref,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Object_Ref), Loc)));
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 (Source_Ref, Loc))),
Make_Assignment_Statement (Loc,
Name =>
Result,
Expression =>
PolyORB_Support.Helpers.Build_From_Any_Call (
RACW_Type,
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of (RTE (RE_TA_ObjRef), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Source_Ref, Loc))),
Decls)));
Build_Stream_Procedure
(Loc, RACW_Type, Body_Node,
Make_Defining_Identifier (Loc, Procedure_Name),
Statements, Outp => True);
Set_Declarations (Body_Node, Decls);
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);
Append_To (Declarations, Body_Node);
end Add_RACW_Read_Attribute;
---------------------
-- Add_RACW_To_Any --
---------------------
procedure Add_RACW_To_Any
(Designated_Type : Entity_Id;
RACW_Type : Entity_Id;
Stub_Type : Entity_Id;
Stub_Type_Access : Entity_Id;
Declarations : List_Id)
is
Loc : constant Source_Ptr := Sloc (RACW_Type);
Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
Fnam : Entity_Id;
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;
Decls : List_Id;
Statements : List_Id;
Null_Statements : List_Id;
Local_Statements : List_Id := No_List;
Stub_Statements : List_Id;
If_Node : Node_Id;
-- Various parts of the subprogram
RACW_Parameter : constant Entity_Id
:= Make_Defining_Identifier (Loc, Name_R);
Reference : constant Entity_Id :=
Make_Defining_Identifier
(Loc, New_Internal_Name ('R'));
Any : constant Entity_Id :=
Make_Defining_Identifier
(Loc, New_Internal_Name ('A'));
begin
-- Object declarations
Decls := New_List (
Make_Object_Declaration (Loc,
Defining_Identifier =>
Reference,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Object_Ref), Loc)),
Make_Object_Declaration (Loc,
Defining_Identifier =>
Any,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Any), Loc)));
-- If the object is null, nothing to do (Reference is already
-- a Nil ref.)
Null_Statements := New_List (Make_Null_Statement (Loc));
if Is_RAS then
-- If the object is a RAS designating a local subprogram,
-- we already have a target reference.
Local_Statements := New_List (
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Set_Ref), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Reference, Loc),
Make_Selected_Component (Loc,
Prefix =>
Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access),
New_Occurrence_Of (RACW_Parameter, Loc)),
Selector_Name => Make_Identifier (Loc, Name_Target)))));
else
-- If the object is a local RACW object, use Get_Reference now
-- to obtain a reference.
Local_Statements := New_List (
Make_Procedure_Call_Statement (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,
Full_Qualified_Name (Designated_Type)),
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (
Defining_Identifier (
Stub_Elements.RPC_Receiver_Decl), Loc),
Attribute_Name =>
Name_Access),
New_Occurrence_Of (Reference, Loc))));
end if;
-- If the object is located on another partition, use the target
-- from the stub.
Stub_Statements := New_List (
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Set_Ref), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Reference, Loc),
Make_Selected_Component (Loc,
Prefix => Unchecked_Convert_To (Stub_Type_Access,
New_Occurrence_Of (RACW_Parameter, Loc)),
Selector_Name =>
Make_Identifier (Loc, Name_Target)))));
-- Distinguish between the null, local and remote cases,
-- and execute the appropriate piece of code.
If_Node :=
Make_Implicit_If_Statement (RACW_Type,
Condition =>
Make_Op_Eq (Loc,
Left_Opnd => New_Occurrence_Of (RACW_Parameter, Loc),
Right_Opnd => Make_Null (Loc)),
Then_Statements => Null_Statements,
Elsif_Parts => New_List (
Make_Elsif_Part (Loc,
Condition =>
Make_Op_Ne (Loc,
Left_Opnd =>
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (RACW_Parameter, Loc),
Attribute_Name => Name_Tag),
Right_Opnd =>
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Stub_Type, Loc),
Attribute_Name => Name_Tag)),
Then_Statements => Local_Statements)),
Else_Statements => Stub_Statements);
Statements := New_List (
If_Node,
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_Return_Statement (Loc,
Expression =>
New_Occurrence_Of (Any, Loc)));
Fnam := Make_Defining_Identifier (
Loc, New_Internal_Name ('T'));
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);
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));
Insert_After (Declaration_Node (RACW_Type), Func_Decl);
Append_To (Declarations, Func_Body);
Set_Renaming_TSS (RACW_Type, Fnam, TSS_To_Any);
end Add_RACW_To_Any;
-----------------------
-- Add_RACW_TypeCode --
-----------------------
procedure Add_RACW_TypeCode
(Designated_Type : Entity_Id;
RACW_Type : Entity_Id;
Declarations : List_Id)
is
Loc : constant Source_Ptr := Sloc (RACW_Type);
Fnam : Entity_Id;
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
Fnam :=
Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('T'));
-- 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);
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_Return_Statement (Loc,
Expression =>
Make_Selected_Component (Loc,
Prefix =>
Defining_Identifier (
Stub_Elements.RPC_Receiver_Decl),
Selector_Name => Name_Obj_TypeCode)))));
Insert_After (Declaration_Node (RACW_Type), Func_Decl);
Append_To (Declarations, Func_Body);
Set_Renaming_TSS (RACW_Type, Fnam, TSS_TypeCode);
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;
Declarations : List_Id)
is
Loc : constant Source_Ptr := Sloc (RACW_Type);
pragma Warnings (Off);
pragma Unreferenced (
Stub_Type,
Stub_Type_Access);
Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
pragma Unreferenced (Is_RAS);
pragma Warnings (On);
Body_Node : Node_Id;
Proc_Decl : Node_Id;
Attr_Decl : Node_Id;
Statements : List_Id;
Procedure_Name : constant Name_Id := New_Internal_Name ('R');
function Stream_Parameter return Node_Id;
function Object return Node_Id;
-- Functions to create occurrences of the formal parameter names
------------
-- Object --
------------
function Object return Node_Id is
Object_Ref : constant Node_Id :=
Make_Identifier (Loc, Name_V);
begin
-- Etype must be set for Build_To_Any_Call
Set_Etype (Object_Ref, RACW_Type);
return Object_Ref;
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
Statements := New_List (
Pack_Node_Into_Stream_Access (Loc,
Stream => Stream_Parameter,
Object =>
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of (RTE (RE_FA_ObjRef), Loc),
Parameter_Associations => New_List (
PolyORB_Support.Helpers.Build_To_Any_Call
(Object, Declarations))),
Etyp => RTE (RE_Object_Ref)));
Build_Stream_Procedure
(Loc, RACW_Type, Body_Node,
Make_Defining_Identifier (Loc, Procedure_Name),
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);
Append_To (Declarations, 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);
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;
Subp_Ref : constant Entity_Id :=
Make_Defining_Identifier (Loc, Name_R);
-- Reference that designates the target subprogram (returned
-- by Get_RAS_Info).
Is_Local : constant Entity_Id :=
Make_Defining_Identifier (Loc, Name_L);
Local_Addr : constant Entity_Id :=
Make_Defining_Identifier (Loc, Name_A);
-- For the call to Get_Local_Address
-- Additional local variables for the remote case
Local_Stub : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('L'));
Stub_Ptr : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('S'));
function Set_Field
(Field_Name : Name_Id;
Value : Node_Id) return Node_Id;
-- Construct an assignment that sets the named component in the
-- returned record
---------------
-- Set_Field --
---------------
function Set_Field
(Field_Name : Name_Id;
Value : Node_Id) return Node_Id
is
begin
return
Make_Assignment_Statement (Loc,
Name =>
Make_Selected_Component (Loc,
Prefix => Stub_Ptr,
Selector_Name => Field_Name),
Expression => Value);
end Set_Field;
-- Start of processing for Add_RAS_Access_TSS
begin
Proc_Decls := New_List (
-- Common declarations
Make_Object_Declaration (Loc,
Defining_Identifier => Subp_Ref,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Object_Ref), Loc)),
Make_Object_Declaration (Loc,
Defining_Identifier => Is_Local,
Object_Definition =>
New_Occurrence_Of (Standard_Boolean, Loc)),
Make_Object_Declaration (Loc,
Defining_Identifier => Local_Addr,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Address), Loc)),
Make_Object_Declaration (Loc,
Defining_Identifier => Local_Stub,
Aliased_Present => True,
Object_Definition =>
New_Occurrence_Of (Stub_Elements.Stub_Type, Loc)),
Make_Object_Declaration (Loc,
Defining_Identifier =>
Stub_Ptr,
Object_Definition =>
New_Occurrence_Of (Stub_Elements.Stub_Type_Access, Loc),
Expression =>
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Local_Stub, Loc),
Attribute_Name => Name_Unchecked_Access)));
Set_Etype (Stub_Ptr, Stub_Elements.Stub_Type_Access);
-- Build_Get_Unique_RP_Call needs this information
-- Get_RAS_Info (Pkg, Subp, R);
-- Obtain a reference to the target subprogram
Proc_Statements := New_List (
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Get_RAS_Info), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Package_Name, Loc),
New_Occurrence_Of (Subp_Id, Loc),
New_Occurrence_Of (Subp_Ref, Loc))),
-- Get_Local_Address (R, L, A);
-- Determine whether the subprogram is local (L), and if so
-- obtain the local address of its proxy (A).
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Subp_Ref, Loc),
New_Occurrence_Of (Is_Local, Loc),
New_Occurrence_Of (Local_Addr, Loc))));
-- Note: Here we assume that the Fat_Type is a record containing just
-- an access to a proxy or stub object.
Append_To (Proc_Statements,
-- if L then
Make_Implicit_If_Statement (N,
Condition =>
New_Occurrence_Of (Is_Local, Loc),
Then_Statements => New_List (
-- if A.Target = null then
Make_Implicit_If_Statement (N,
Condition =>
Make_Op_Eq (Loc,
Make_Selected_Component (Loc,
Prefix =>
Unchecked_Convert_To (
RTE (RE_RAS_Proxy_Type_Access),
New_Occurrence_Of (Local_Addr, Loc)),
Selector_Name =>
Make_Identifier (Loc, Name_Target)),
Make_Null (Loc)),
Then_Statements => New_List (
-- A.Target := Entity_Of (Ref);
Make_Assignment_Statement (Loc,
Name =>
Make_Selected_Component (Loc,
Prefix =>
Unchecked_Convert_To (
RTE (RE_RAS_Proxy_Type_Access),
New_Occurrence_Of (Local_Addr, Loc)),
Selector_Name =>
Make_Identifier (Loc, Name_Target)),
Expression =>
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Entity_Of), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Subp_Ref, Loc)))),
-- Inc_Usage (A.Target);
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Inc_Usage), Loc),
Parameter_Associations => New_List (
Make_Selected_Component (Loc,
Prefix =>
Unchecked_Convert_To (
RTE (RE_RAS_Proxy_Type_Access),
New_Occurrence_Of (Local_Addr, Loc)),
Selector_Name => Make_Identifier (Loc,
Name_Target)))))),
-- end if;
-- if not All_Calls_Remote then
-- return Fat_Type!(A);
-- end if;
Make_Implicit_If_Statement (N,
Condition =>
Make_Op_Not (Loc,
New_Occurrence_Of (All_Calls_Remote, Loc)),
Then_Statements => New_List (
Make_Return_Statement (Loc,
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,
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));
Append_To (Proc_Statements,
Make_Return_Statement (Loc,
Expression =>
Unchecked_Convert_To (Fat_Type,
New_Occurrence_Of (Stub_Ptr, Loc))));
Proc_Spec :=
Make_Function_Specification (Loc,
Defining_Unit_Name => Proc,
Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier => Package_Name,
Parameter_Type =>
New_Occurrence_Of (Standard_String, Loc)),
Make_Parameter_Specification (Loc,
Defining_Identifier => Subp_Id,
Parameter_Type =>
New_Occurrence_Of (Standard_String, Loc)),
Make_Parameter_Specification (Loc,
Defining_Identifier => Asynch_P,
Parameter_Type =>
New_Occurrence_Of (Standard_Boolean, Loc)),
Make_Parameter_Specification (Loc,
Defining_Identifier => All_Calls_Remote,
Parameter_Type =>
New_Occurrence_Of (Standard_Boolean, Loc))),
Result_Definition =>
New_Occurrence_Of (Fat_Type, Loc));
-- Set the kind and return type of the function to prevent
-- ambiguities between Ras_Type and Fat_Type in subsequent analysis.
Set_Ekind (Proc, E_Function);
Set_Etype (Proc, Fat_Type);
Discard_Node (
Make_Subprogram_Body (Loc,
Specification => Proc_Spec,
Declarations => Proc_Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Proc_Statements)));
Set_TSS (Fat_Type, Proc);
end Add_RAS_Access_TSS;
----------------------
-- Add_RAS_From_Any --
----------------------
procedure Add_RAS_From_Any (RAS_Type : Entity_Id) is
Loc : constant Source_Ptr := Sloc (RAS_Type);
Fnam : constant Entity_Id := Make_Defining_Identifier (Loc,
Make_TSS_Name (RAS_Type, TSS_From_Any));
Func_Spec : Node_Id;
Statements : List_Id;
Any_Parameter : constant Entity_Id :=
Make_Defining_Identifier (Loc, Name_A);
begin
Statements := New_List (
Make_Return_Statement (Loc,
Expression =>
Make_Aggregate (Loc,
Component_Associations => New_List (
Make_Component_Association (Loc,
Choices => New_List (
Make_Identifier (Loc, Name_Ras)),
Expression =>
PolyORB_Support.Helpers.Build_From_Any_Call (
Underlying_RACW_Type (RAS_Type),
New_Occurrence_Of (Any_Parameter, Loc),
No_List))))));
Func_Spec :=
Make_Function_Specification (Loc,
Defining_Unit_Name =>
Fnam,
Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier =>
Any_Parameter,
Parameter_Type =>
New_Occurrence_Of (RTE (RE_Any), Loc))),
Result_Definition => New_Occurrence_Of (RAS_Type, Loc));
Discard_Node (
Make_Subprogram_Body (Loc,
Specification => Func_Spec,
Declarations => No_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Statements)));
Set_TSS (RAS_Type, Fnam);
end Add_RAS_From_Any;
--------------------
-- Add_RAS_To_Any --
--------------------
procedure Add_RAS_To_Any (RAS_Type : Entity_Id) is
Loc : constant Source_Ptr := Sloc (RAS_Type);
Fnam : constant Entity_Id := Make_Defining_Identifier (Loc,
Make_TSS_Name (RAS_Type, TSS_To_Any));
Decls : List_Id;
Statements : List_Id;
Func_Spec : Node_Id;
Any : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('A'));
RAS_Parameter : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('R'));
RACW_Parameter : constant Node_Id :=
Make_Selected_Component (Loc,
Prefix => RAS_Parameter,
Selector_Name => Name_Ras);
begin
-- Object declarations
Set_Etype (RACW_Parameter, Underlying_RACW_Type (RAS_Type));
Decls := New_List (
Make_Object_Declaration (Loc,
Defining_Identifier =>
Any,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Any), Loc),
Expression =>
PolyORB_Support.Helpers.Build_To_Any_Call
(RACW_Parameter, No_List)));
Statements := New_List (
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Set_TC), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Any, Loc),
PolyORB_Support.Helpers.Build_TypeCode_Call (Loc,
RAS_Type, Decls))),
Make_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, 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_Return_Statement (Loc,
Expression =>
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of (RTE (RE_TC_Build), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (RTE (RE_TC_Object), Loc),
Make_Aggregate (Loc,
Expressions =>
New_List (
Make_Function_Call (Loc,
Name => New_Occurrence_Of (
RTE (RE_TA_String), Loc),
Parameter_Associations => New_List (
Make_String_Literal (Loc, Name_String))),
Make_Function_Call (Loc,
Name => New_Occurrence_Of (
RTE (RE_TA_String), Loc),
Parameter_Associations => New_List (
Make_String_Literal (Loc,
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)
is
Loc : constant Source_Ptr := Sloc (Pkg_Spec);
Pkg_RPC_Receiver : constant Entity_Id :=
Make_Defining_Identifier (Loc,
New_Internal_Name ('H'));
Pkg_RPC_Receiver_Object : Node_Id;
Pkg_RPC_Receiver_Body : Node_Id;
Pkg_RPC_Receiver_Decls : List_Id;
Pkg_RPC_Receiver_Statements : List_Id;
Pkg_RPC_Receiver_Cases : constant List_Id := New_List;
-- A Pkg_RPC_Receiver is built to decode the request
Request : Node_Id;
-- Request object received from neutral layer
Subp_Id : Entity_Id;
-- Subprogram identifier as received from the neutral
-- distribution core.
Subp_Index : Entity_Id;
-- Internal index as determined by matching either the
-- method name from the request structure, or the local
-- subprogram address (in case of a RAS).
Is_Local : constant Entity_Id :=
Make_Defining_Identifier (Loc, New_Internal_Name ('L'));
Local_Address : constant Entity_Id :=
Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
-- Address of a local subprogram designated by a
-- reference corresponding to a RAS.
Dispatch_On_Address : constant List_Id := New_List;
Dispatch_On_Name : constant List_Id := New_List;
Current_Declaration : Node_Id;
Current_Stubs : Node_Id;
Current_Subprogram_Number : Int := First_RCI_Subprogram_Id;
Subp_Info_Array : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('I'));
Subp_Info_List : constant List_Id := New_List;
Register_Pkg_Actuals : constant List_Id := New_List;
All_Calls_Remote_E : Entity_Id;
procedure Append_Stubs_To
(RPC_Receiver_Cases : List_Id;
Declaration : Node_Id;
Stubs : Node_Id;
Subp_Number : Int;
Subp_Dist_Name : Entity_Id;
Subp_Proxy_Addr : Entity_Id);
-- Add one case to the specified RPC receiver case list associating
-- Subprogram_Number with the subprogram declared by Declaration, for
-- which we have receiving stubs in Stubs. Subp_Number is an internal
-- subprogram index. Subp_Dist_Name is the string used to call the
-- subprogram by name, and Subp_Dist_Addr is the address of the proxy
-- object, used in the context of calls through remote
-- access-to-subprogram types.
---------------------
-- Append_Stubs_To --
---------------------
procedure Append_Stubs_To
(RPC_Receiver_Cases : List_Id;
Declaration : Node_Id;
Stubs : Node_Id;
Subp_Number : Int;
Subp_Dist_Name : Entity_Id;
Subp_Proxy_Addr : Entity_Id)
is
Case_Stmts : List_Id;
begin
Case_Stmts := New_List (
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (
Defining_Entity (Stubs), Loc),
Parameter_Associations =>
New_List (New_Occurrence_Of (Request, Loc))));
if Nkind (Specification (Declaration))
= N_Function_Specification
or else not
Is_Asynchronous (Defining_Entity (Specification (Declaration)))
then
Append_To (Case_Stmts, Make_Return_Statement (Loc));
end if;
Append_To (RPC_Receiver_Cases,
Make_Case_Statement_Alternative (Loc,
Discrete_Choices =>
New_List (Make_Integer_Literal (Loc, Subp_Number)),
Statements =>
Case_Stmts));
Append_To (Dispatch_On_Name,
Make_Elsif_Part (Loc,
Condition =>
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Caseless_String_Eq), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Subp_Id, Loc),
New_Occurrence_Of (Subp_Dist_Name, Loc))),
Then_Statements => New_List (
Make_Assignment_Statement (Loc,
New_Occurrence_Of (Subp_Index, Loc),
Make_Integer_Literal (Loc,
Subp_Number)))));
Append_To (Dispatch_On_Address,
Make_Elsif_Part (Loc,
Condition =>
Make_Op_Eq (Loc,
Left_Opnd =>
New_Occurrence_Of (Local_Address, Loc),
Right_Opnd =>
New_Occurrence_Of (Subp_Proxy_Addr, Loc)),
Then_Statements => New_List (
Make_Assignment_Statement (Loc,
New_Occurrence_Of (Subp_Index, Loc),
Make_Integer_Literal (Loc,
Subp_Number)))));
end Append_Stubs_To;
-- Start of processing for Add_Receiving_Stubs_To_Declarations
begin
-- Building receiving stubs consist in several operations:
-- - a package RPC receiver must be built. This subprogram
-- will get a Subprogram_Id from the incoming stream
-- and will dispatch the call to the right subprogram
-- - a receiving stub for any subprogram visible in the package
-- spec. This stub will read all the parameters from the stream,
-- and put the result as well as the exception occurrence in the
-- output stream
-- - a dummy package with an empty spec and a body made of an
-- elaboration part, whose job is to register the receiving
-- part of this RCI package on the name server. This is done
-- by calling System.Partition_Interface.Register_Receiving_Stub
Build_RPC_Receiver_Body (
RPC_Receiver => Pkg_RPC_Receiver,
Request => Request,
Subp_Id => Subp_Id,
Subp_Index => Subp_Index,
Stmts => Pkg_RPC_Receiver_Statements,
Decl => Pkg_RPC_Receiver_Body);
Pkg_RPC_Receiver_Decls := Declarations (Pkg_RPC_Receiver_Body);
-- Extract local address information from the target reference:
-- if non-null, that means that this is a reference that denotes
-- one particular operation, and hence that the operation name
-- must not be taken into account for dispatching.
Append_To (Pkg_RPC_Receiver_Decls,
Make_Object_Declaration (Loc,
Defining_Identifier =>
Is_Local,
Object_Definition =>
New_Occurrence_Of (Standard_Boolean, Loc)));
Append_To (Pkg_RPC_Receiver_Decls,
Make_Object_Declaration (Loc,
Defining_Identifier =>
Local_Address,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Address), Loc)));
Append_To (Pkg_RPC_Receiver_Statements,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc),
Parameter_Associations => New_List (
Make_Selected_Component (Loc,
Prefix => Request,
Selector_Name => Name_Target),
New_Occurrence_Of (Is_Local, Loc),
New_Occurrence_Of (Local_Address, Loc))));
-- Determine whether the reference that was used to make
-- the call was the base RCI reference (in which case
-- Local_Address is 0, 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).
-- 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))));
-- For each subprogram, the receiving stub will be built and a
-- case statement will be made on the Subprogram_Id to dispatch
-- to the right subprogram.
All_Calls_Remote_E := Boolean_Literals (
Has_All_Calls_Remote (Defining_Entity (Pkg_Spec)));
Overload_Counter_Table.Reset;
Reserve_NamingContext_Methods;
Current_Declaration := First (Visible_Declarations (Pkg_Spec));
while Present (Current_Declaration) loop
if Nkind (Current_Declaration) = N_Subprogram_Declaration
and then Comes_From_Source (Current_Declaration)
then
declare
Loc : constant Source_Ptr :=
Sloc (Current_Declaration);
-- While specifically processing Current_Declaration, use
-- its Sloc as the location of all generated nodes.
Subp_Def : constant Entity_Id :=
Defining_Unit_Name
(Specification (Current_Declaration));
Subp_Val : String_Id;
Subp_Dist_Name : constant Entity_Id :=
Make_Defining_Identifier (Loc,
New_External_Name (
Related_Id => Chars (Subp_Def),
Suffix => 'D',
Suffix_Index => -1));
Proxy_Object_Addr : Entity_Id;
begin
pragma Assert (Current_Subprogram_Number =
Get_Subprogram_Id (Subp_Def));
-- Build receiving stub
Current_Stubs :=
Build_Subprogram_Receiving_Stubs
(Vis_Decl => Current_Declaration,
Asynchronous =>
Nkind (Specification (Current_Declaration)) =
N_Procedure_Specification
and then Is_Asynchronous (Subp_Def));
Append_To (Decls, Current_Stubs);
Analyze (Current_Stubs);
-- Build RAS proxy
Add_RAS_Proxy_And_Analyze (Decls,
Vis_Decl =>
Current_Declaration,
All_Calls_Remote_E =>
All_Calls_Remote_E,
Proxy_Object_Addr =>
Proxy_Object_Addr);
-- Compute distribution identifier
Assign_Subprogram_Identifier (
Subp_Def,
Current_Subprogram_Number,
Subp_Val);
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => Subp_Dist_Name,
Constant_Present => True,
Object_Definition => New_Occurrence_Of (
Standard_String, Loc),
Expression =>
Make_String_Literal (Loc, Subp_Val)));
Analyze (Last (Decls));
-- Add subprogram descriptor (RCI_Subp_Info) to the
-- subprograms table for this receiver. The aggregate
-- below must be kept consistent with the declaration
-- of type RCI_Subp_Info in System.Partition_Interface.
Append_To (Subp_Info_List,
Make_Component_Association (Loc,
Choices => New_List (
Make_Integer_Literal (Loc,
Current_Subprogram_Number)),
Expression =>
Make_Aggregate (Loc,
Expressions => New_List (
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (
Subp_Dist_Name, Loc),
Attribute_Name => Name_Address),
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (
Subp_Dist_Name, Loc),
Attribute_Name => Name_Length),
New_Occurrence_Of (Proxy_Object_Addr, Loc)))));
Append_Stubs_To (Pkg_RPC_Receiver_Cases,
Declaration => Current_Declaration,
Stubs => Current_Stubs,
Subp_Number => Current_Subprogram_Number,
Subp_Dist_Name => Subp_Dist_Name,
Subp_Proxy_Addr => Proxy_Object_Addr);
end;
Current_Subprogram_Number := Current_Subprogram_Number + 1;
end if;
Next (Current_Declaration);
end loop;
-- 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));
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,
First_RCI_Subprogram_Id
+ List_Length (Subp_Info_List) - 1))))),
Expression =>
Make_Aggregate (Loc,
Component_Associations => Subp_Info_List)));
Analyze (Last (Decls));
Append_To (Decls, Pkg_RPC_Receiver_Body);
Analyze (Last (Decls));
Pkg_RPC_Receiver_Object :=
Make_Object_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, New_Internal_Name ('R')),
Aliased_Present => True,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Servant), Loc));
Append_To (Decls, Pkg_RPC_Receiver_Object);
Analyze (Last (Decls));
Get_Library_Unit_Name_String (Pkg_Spec);
Append_To (Register_Pkg_Actuals,
-- Name
Make_String_Literal (Loc,
Strval => String_From_Name_Buffer));
Append_To (Register_Pkg_Actuals,
-- Version
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of
(Defining_Entity (Pkg_Spec), Loc),
Attribute_Name =>
Name_Version));
Append_To (Register_Pkg_Actuals,
-- Handler
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Pkg_RPC_Receiver, Loc),
Attribute_Name => Name_Access));
Append_To (Register_Pkg_Actuals,
-- Receiver
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (
Defining_Identifier (
Pkg_RPC_Receiver_Object), Loc),
Attribute_Name =>
Name_Access));
Append_To (Register_Pkg_Actuals,
-- Subp_Info
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Subp_Info_Array, Loc),
Attribute_Name =>
Name_Address));
Append_To (Register_Pkg_Actuals,
-- Subp_Info_Len
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Subp_Info_Array, Loc),
Attribute_Name =>
Name_Length));
Append_To (Register_Pkg_Actuals,
-- Is_All_Calls_Remote
New_Occurrence_Of (All_Calls_Remote_E, Loc));
Append_To (Decls,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Register_Pkg_Receiving_Stub), Loc),
Parameter_Associations => Register_Pkg_Actuals));
Analyze (Last (Decls));
end Add_Receiving_Stubs_To_Declarations;
---------------------------------
-- Build_General_Calling_Stubs --
---------------------------------
procedure Build_General_Calling_Stubs
(Decls : List_Id;
Statements : List_Id;
Target_Object : Node_Id;
Subprogram_Id : Node_Id;
Asynchronous : Node_Id := Empty;
Is_Known_Asynchronous : Boolean := False;
Is_Known_Non_Asynchronous : Boolean := False;
Is_Function : Boolean;
Spec : Node_Id;
Stub_Type : Entity_Id := Empty;
RACW_Type : Entity_Id := Empty;
Nod : Node_Id)
is
Loc : constant Source_Ptr := Sloc (Nod);
Arguments : Node_Id;
-- Name of the named values list used to transmit parameters
-- to the remote package
Request : Node_Id;
-- The request object constructed by these stubs
Result : Node_Id;
-- Name of the result named value (in non-APC cases) which get the
-- result of the remote subprogram.
Result_TC : Node_Id;
-- Typecode expression for the result of the request (void
-- typecode for procedures).
Exception_Return_Parameter : Node_Id;
-- Name of the parameter which will hold the exception sent by the
-- remote subprogram.
Current_Parameter : Node_Id;
-- Current parameter being handled
Ordered_Parameters_List : constant List_Id :=
Build_Ordered_Parameters_List (Spec);
Asynchronous_P : Node_Id;
-- A Boolean expression indicating whether this call is asynchronous
Asynchronous_Statements : List_Id := No_List;
Non_Asynchronous_Statements : List_Id := No_List;
-- Statements specifics to the Asynchronous/Non-Asynchronous cases
Extra_Formal_Statements : constant List_Id := New_List;
-- List of statements for extra formal parameters. It will appear
-- after the regular statements for writing out parameters.
After_Statements : constant List_Id := New_List;
-- Statements to be executed after call returns (to assign
-- in out or out parameter values).
Etyp : Entity_Id;
-- The type of the formal parameter being processed
Is_Controlling_Formal : Boolean;
Is_First_Controlling_Formal : Boolean;
First_Controlling_Formal_Seen : Boolean := False;
-- Controlling formal parameters of distributed object
-- primitives require special handling, and the first
-- such parameter needs even more.
begin
-- ??? document general form of stub subprograms for the PolyORB case
Request :=
Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => Request,
Aliased_Present => False,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Request_Access), Loc)));
Result :=
Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
if Is_Function then
Result_TC := PolyORB_Support.Helpers.Build_TypeCode_Call (Loc,
Etype (Result_Definition (Spec)), Decls);
else
Result_TC := New_Occurrence_Of (RTE (RE_TC_Void), Loc);
end if;
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => Result,
Aliased_Present => False,
Object_Definition =>
New_Occurrence_Of (RTE (RE_NamedValue), Loc),
Expression =>
Make_Aggregate (Loc,
Component_Associations => New_List (
Make_Component_Association (Loc,
Choices => New_List (
Make_Identifier (Loc, Name_Name)),
Expression =>
New_Occurrence_Of (RTE (RE_Result_Name), Loc)),
Make_Component_Association (Loc,
Choices => New_List (
Make_Identifier (Loc, Name_Argument)),
Expression =>
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Create_Any), Loc),
Parameter_Associations => New_List (
Result_TC))),
Make_Component_Association (Loc,
Choices => New_List (
Make_Identifier (Loc, Name_Arg_Modes)),
Expression =>
Make_Integer_Literal (Loc, 0))))));
if not Is_Known_Asynchronous then
Exception_Return_Parameter :=
Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => Exception_Return_Parameter,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc)));
else
Exception_Return_Parameter := Empty;
end if;
-- Initialize and fill in arguments list
Arguments :=
Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
Declare_Create_NVList (Loc, Arguments, Decls, Statements);
Current_Parameter := First (Ordered_Parameters_List);
while Present (Current_Parameter) loop
if Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type) then
Is_Controlling_Formal := True;
Is_First_Controlling_Formal :=
not First_Controlling_Formal_Seen;
First_Controlling_Formal_Seen := True;
else
Is_Controlling_Formal := False;
Is_First_Controlling_Formal := False;
end if;
if Is_Controlling_Formal then
-- In the case of a controlling formal argument, we send
-- its reference.
Etyp := RACW_Type;
else
Etyp := Etype (Parameter_Type (Current_Parameter));
end if;
-- The first controlling formal parameter is treated
-- specially: it is used to set the target object of
-- the call.
if not Is_First_Controlling_Formal then
declare
Constrained : constant Boolean :=
Is_Constrained (Etyp)
or else Is_Elementary_Type (Etyp);
Any : constant Entity_Id :=
Make_Defining_Identifier (Loc,
New_Internal_Name ('A'));
Actual_Parameter : Node_Id :=
New_Occurrence_Of (
Defining_Identifier (
Current_Parameter), Loc);
Expr : Node_Id;
begin
if Is_Controlling_Formal then
-- For a controlling formal parameter (other
-- than the first one), use the corresponding
-- RACW. If the parameter is not an anonymous
-- access parameter, that involves taking
-- its 'Unrestricted_Access.
if Nkind (Parameter_Type (Current_Parameter))
= N_Access_Definition
then
Actual_Parameter := OK_Convert_To
(Etyp, Actual_Parameter);
else
Actual_Parameter := OK_Convert_To (Etyp,
Make_Attribute_Reference (Loc,
Prefix =>
Actual_Parameter,
Attribute_Name =>
Name_Unrestricted_Access));
end if;
end if;
if In_Present (Current_Parameter)
or else not Out_Present (Current_Parameter)
or else not Constrained
or else Is_Controlling_Formal
then
-- The parameter has an input value, is constrained
-- at runtime by an input value, or is a controlling
-- formal parameter (always passed as a reference)
-- other than the first one.
Expr := PolyORB_Support.Helpers.Build_To_Any_Call (
Actual_Parameter, Decls);
else
Expr := Make_Function_Call (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Create_Any), Loc),
Parameter_Associations => New_List (
PolyORB_Support.Helpers.Build_TypeCode_Call (Loc,
Etyp, Decls)));
end if;
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier =>
Any,
Aliased_Present => False,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Any), Loc),
Expression =>
Expr));
Append_To (Statements,
Add_Parameter_To_NVList (Loc,
Parameter => Current_Parameter,
NVList => Arguments,
Constrained => Constrained,
Any => Any));
if Out_Present (Current_Parameter)
and then not Is_Controlling_Formal
then
Append_To (After_Statements,
Make_Assignment_Statement (Loc,
Name =>
New_Occurrence_Of (
Defining_Identifier (Current_Parameter), Loc),
Expression =>
PolyORB_Support.Helpers.Build_From_Any_Call (
Etype (Parameter_Type (Current_Parameter)),
New_Occurrence_Of (Any, Loc),
Decls)));
end if;
end;
end if;
-- If the current parameter has a dynamic constrained status,
-- then this status is transmitted as well.
-- This should be done for accessibility as well ???
if Nkind (Parameter_Type (Current_Parameter))
/= N_Access_Definition
and then Need_Extra_Constrained (Current_Parameter)
then
-- In this block, we do not use the extra formal that has been
-- created because it does not exist at the time of expansion
-- when building calling stubs for remote access to subprogram
-- types. We create an extra variable of this type and push it
-- in the stream after the regular parameters.
declare
Extra_Any_Parameter : constant Entity_Id :=
Make_Defining_Identifier
(Loc, New_Internal_Name ('P'));
begin
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 (
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (
Defining_Identifier (Current_Parameter), Loc),
Attribute_Name => Name_Constrained),
Decls)));
Append_To (Extra_Formal_Statements,
Add_Parameter_To_NVList (Loc,
Parameter => Extra_Any_Parameter,
NVList => Arguments,
Constrained => True,
Any => Extra_Any_Parameter));
end;
end if;
Next (Current_Parameter);
end loop;
-- Append the formal statements list to the statements
Append_List_To (Statements, Extra_Formal_Statements);
Append_To (Statements,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Request_Create), Loc),
Parameter_Associations => New_List (
Target_Object,
Subprogram_Id,
New_Occurrence_Of (Arguments, Loc),
New_Occurrence_Of (Result, Loc),
New_Occurrence_Of (RTE (RE_Nil_Exc_List), Loc))));
Append_To (Parameter_Associations (Last (Statements)),
New_Occurrence_Of (Request, Loc));
pragma Assert (
not (Is_Known_Non_Asynchronous and Is_Known_Asynchronous));
if Is_Known_Non_Asynchronous or Is_Known_Asynchronous then
Asynchronous_P := New_Occurrence_Of (
Boolean_Literals (Is_Known_Asynchronous), Loc);
else
pragma Assert (Present (Asynchronous));
Asynchronous_P := New_Copy_Tree (Asynchronous);
-- The expression node Asynchronous will be used to build
-- an 'if' statement at the end of Build_General_Calling_Stubs:
-- we need to make a copy here.
end if;
Append_To (Parameter_Associations (Last (Statements)),
Make_Indexed_Component (Loc,
Prefix =>
New_Occurrence_Of (
RTE (RE_Asynchronous_P_To_Sync_Scope), Loc),
Expressions => New_List (Asynchronous_P)));
Append_To (Statements,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Request_Invoke), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Request, Loc))));
Non_Asynchronous_Statements := New_List (Make_Null_Statement (Loc));
Asynchronous_Statements := New_List (Make_Null_Statement (Loc));
if not Is_Known_Asynchronous then
-- Reraise an exception occurrence from the completed request.
-- If the exception occurrence is empty, this is a no-op.
Append_To (Non_Asynchronous_Statements,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Request_Raise_Occurrence), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Request, Loc))));
if Is_Function then
-- If this is a function call, then read the value and
-- return it.
Append_To (Non_Asynchronous_Statements,
Make_Tag_Check (Loc,
Make_Return_Statement (Loc,
PolyORB_Support.Helpers.Build_From_Any_Call (
Etype (Result_Definition (Spec)),
Make_Selected_Component (Loc,
Prefix => Result,
Selector_Name => Name_Argument),
Decls))));
end if;
end if;
Append_List_To (Non_Asynchronous_Statements,
After_Statements);
if Is_Known_Asynchronous then
Append_List_To (Statements, Asynchronous_Statements);
elsif Is_Known_Non_Asynchronous then
Append_List_To (Statements, Non_Asynchronous_Statements);
else
pragma Assert (Present (Asynchronous));
Append_To (Statements,
Make_Implicit_If_Statement (Nod,
Condition => Asynchronous,
Then_Statements => Asynchronous_Statements,
Else_Statements => Non_Asynchronous_Statements));
end if;
end Build_General_Calling_Stubs;
-----------------------
-- Build_Stub_Target --
-----------------------
function Build_Stub_Target
(Loc : Source_Ptr;
Decls : List_Id;
RCI_Locator : Entity_Id;
Controlling_Parameter : Entity_Id) return RPC_Target
is
Target_Info : RPC_Target (PCS_Kind => Name_PolyORB_DSA);
Target_Reference : constant Entity_Id :=
Make_Defining_Identifier (Loc,
New_Internal_Name ('T'));
begin
if Present (Controlling_Parameter) then
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => Target_Reference,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Object_Ref), Loc),
Expression =>
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Make_Ref), Loc),
Parameter_Associations => New_List (
Make_Selected_Component (Loc,
Prefix => Controlling_Parameter,
Selector_Name => Name_Target)))));
-- Controlling_Parameter has the same components
-- as System.Partition_Interface.RACW_Stub_Type.
Target_Info.Object := New_Occurrence_Of (Target_Reference, Loc);
else
Target_Info.Object :=
Make_Selected_Component (Loc,
Prefix =>
Make_Identifier (Loc, Chars (RCI_Locator)),
Selector_Name =>
Make_Identifier (Loc, Name_Get_RCI_Package_Ref));
end if;
return Target_Info;
end Build_Stub_Target;
---------------------
-- Build_Stub_Type --
---------------------
procedure Build_Stub_Type
(RACW_Type : Entity_Id;
Stub_Type : Entity_Id;
Stub_Type_Decl : out Node_Id;
RPC_Receiver_Decl : out Node_Id)
is
Loc : constant Source_Ptr := Sloc (Stub_Type);
pragma Warnings (Off);
pragma Unreferenced (RACW_Type);
pragma Warnings (On);
begin
Stub_Type_Decl :=
Make_Full_Type_Declaration (Loc,
Defining_Identifier => Stub_Type,
Type_Definition =>
Make_Record_Definition (Loc,
Tagged_Present => True,
Limited_Present => True,
Component_List =>
Make_Component_List (Loc,
Component_Items => New_List (
Make_Component_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_Target),
Component_Definition =>
Make_Component_Definition (Loc,
Aliased_Present =>
False,
Subtype_Indication =>
New_Occurrence_Of (RTE (RE_Entity_Ptr), Loc))),
Make_Component_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_Asynchronous),
Component_Definition =>
Make_Component_Definition (Loc,
Aliased_Present => False,
Subtype_Indication =>
New_Occurrence_Of (
Standard_Boolean, Loc)))))));
RPC_Receiver_Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc,
New_Internal_Name ('R')),
Aliased_Present => True,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Servant), Loc));
end Build_Stub_Type;
-----------------------------
-- Build_RPC_Receiver_Body --
-----------------------------
procedure Build_RPC_Receiver_Body
(RPC_Receiver : Entity_Id;
Request : out Entity_Id;
Subp_Id : out Entity_Id;
Subp_Index : out Entity_Id;
Stmts : out List_Id;
Decl : out Node_Id)
is
Loc : constant Source_Ptr := Sloc (RPC_Receiver);
RPC_Receiver_Spec : Node_Id;
RPC_Receiver_Decls : List_Id;
begin
Request := Make_Defining_Identifier (Loc, Name_R);
RPC_Receiver_Spec :=
Build_RPC_Receiver_Specification (
RPC_Receiver => RPC_Receiver,
Request_Parameter => Request);
Subp_Id := Make_Defining_Identifier (Loc, Name_P);
Subp_Index := Make_Defining_Identifier (Loc, Name_I);
RPC_Receiver_Decls := New_List (
Make_Object_Renaming_Declaration (Loc,
Defining_Identifier => Subp_Id,
Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
Name =>
Make_Explicit_Dereference (Loc,
Prefix =>
Make_Selected_Component (Loc,
Prefix => Request,
Selector_Name => Name_Operation))),
Make_Object_Declaration (Loc,
Defining_Identifier => Subp_Index,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
Expression =>
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
Attribute_Name => Name_Last)));
Stmts := New_List;
Decl :=
Make_Subprogram_Body (Loc,
Specification => RPC_Receiver_Spec,
Declarations => RPC_Receiver_Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Stmts));
end Build_RPC_Receiver_Body;
--------------------------------------
-- Build_Subprogram_Receiving_Stubs --
--------------------------------------
function Build_Subprogram_Receiving_Stubs
(Vis_Decl : Node_Id;
Asynchronous : Boolean;
Dynamically_Asynchronous : Boolean := False;
Stub_Type : Entity_Id := Empty;
RACW_Type : Entity_Id := Empty;
Parent_Primitive : Entity_Id := Empty) return Node_Id
is
Loc : constant Source_Ptr := Sloc (Vis_Decl);
Request_Parameter : Node_Id;
-- ???
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.
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;
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;
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 : Node_Id;
-- 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;
Request_Parameter :=
Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
Arguments :=
Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
Declare_Create_NVList (Loc, Arguments, Outer_Decls, Outer_Statements);
-- Loop through every parameter and get its value from the stream. If
-- the parameter is unconstrained, then the parameter is read using
-- 'Input at the point of declaration.
Current_Parameter := First (Ordered_Parameters_List);
while Present (Current_Parameter) loop
declare
Etyp : Entity_Id;
Constrained : Boolean;
Any : Entity_Id := Empty;
Object : constant Entity_Id :=
Make_Defining_Identifier (Loc,
New_Internal_Name ('P'));
Expr : Node_Id := Empty;
Is_Controlling_Formal : constant Boolean
:= Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type);
Is_First_Controlling_Formal : Boolean := False;
begin
Set_Ekind (Object, E_Variable);
if Is_Controlling_Formal then
-- Controlling formals in distributed object primitive
-- operations are handled specially:
-- - the first controlling formal is used as the
-- target of the call;
-- - the remaining controlling formals are transmitted
-- as RACWs.
Etyp := RACW_Type;
Is_First_Controlling_Formal :=
not First_Controlling_Formal_Seen;
First_Controlling_Formal_Seen := True;
else
Etyp := Etype (Parameter_Type (Current_Parameter));
end if;
Constrained :=
Is_Constrained (Etyp)
or else Is_Elementary_Type (Etyp);
if not Is_First_Controlling_Formal then
Any := Make_Defining_Identifier (Loc,
New_Internal_Name ('A'));
Append_To (Outer_Decls,
Make_Object_Declaration (Loc,
Defining_Identifier =>
Any,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Any), Loc),
Expression =>
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Create_Any), Loc),
Parameter_Associations => New_List (
PolyORB_Support.Helpers.Build_TypeCode_Call (Loc,
Etyp, Outer_Decls)))));
Append_To (Outer_Statements,
Add_Parameter_To_NVList (Loc,
Parameter => Current_Parameter,
NVList => Arguments,
Constrained => Constrained,
Any => Any));
end if;
if Is_First_Controlling_Formal then
declare
Addr : constant Entity_Id :=
Make_Defining_Identifier (Loc,
New_Internal_Name ('A'));
Is_Local : constant Entity_Id :=
Make_Defining_Identifier (Loc,
New_Internal_Name ('L'));
begin
-- Special case: obtain the first controlling
-- formal from the target of the remote call,
-- instead of the argument list.
Append_To (Outer_Decls,
Make_Object_Declaration (Loc,
Defining_Identifier =>
Addr,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Address), Loc)));
Append_To (Outer_Decls,
Make_Object_Declaration (Loc,
Defining_Identifier =>
Is_Local,
Object_Definition =>
New_Occurrence_Of (Standard_Boolean, Loc)));
Append_To (Outer_Statements,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (
RTE (RE_Get_Local_Address), Loc),
Parameter_Associations => New_List (
Make_Selected_Component (Loc,
Prefix =>
New_Occurrence_Of (
Request_Parameter, Loc),
Selector_Name =>
Make_Identifier (Loc, Name_Target)),
New_Occurrence_Of (Is_Local, Loc),
New_Occurrence_Of (Addr, Loc))));
Expr := Unchecked_Convert_To (RACW_Type,
New_Occurrence_Of (Addr, Loc));
end;
elsif In_Present (Current_Parameter)
or else not Out_Present (Current_Parameter)
or else not Constrained
then
-- If an input parameter is contrained, then its reading is
-- deferred until the beginning of the subprogram body. If
-- it is unconstrained, then an expression is built for
-- the object declaration and the variable is set using
-- 'Input instead of 'Read.
Expr := PolyORB_Support.Helpers.Build_From_Any_Call (
Etyp, New_Occurrence_Of (Any, Loc), Decls);
if Constrained then
Append_To (Statements,
Make_Assignment_Statement (Loc,
Name =>
New_Occurrence_Of (Object, Loc),
Expression =>
Expr));
Expr := Empty;
else
null;
-- Expr will be used to initialize (and constrain)
-- the parameter when it is declared.
end if;
end if;
-- If we do not have to output the current parameter, then
-- it can well be flagged as constant. This may allow further
-- optimizations done by the back end.
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => Object,
Constant_Present => not Constrained
and then not Out_Present (Current_Parameter),
Object_Definition =>
New_Occurrence_Of (Etyp, Loc),
Expression => Expr));
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_Copy_Any_Value), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Any, Loc),
PolyORB_Support.Helpers.Build_To_Any_Call (
New_Occurrence_Of (Object, Loc),
Decls))));
end if;
-- For RACW controlling formals, the Etyp of Object is always
-- an RACW, even if the parameter is not of an anonymous access
-- type. In such case, we need to dereference it at call time.
if Is_Controlling_Formal then
if Nkind (Parameter_Type (Current_Parameter)) /=
N_Access_Definition
then
Append_To (Parameter_List,
Make_Parameter_Association (Loc,
Selector_Name =>
New_Occurrence_Of (
Defining_Identifier (Current_Parameter), Loc),
Explicit_Actual_Parameter =>
Make_Explicit_Dereference (Loc,
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 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)))
then
declare
Extra_Parameter : constant Entity_Id :=
Extra_Constrained
(Defining_Identifier
(Current_Parameter));
Extra_Any : constant Entity_Id :=
Make_Defining_Identifier
(Loc, New_Internal_Name ('A'));
Formal_Entity : constant Entity_Id :=
Make_Defining_Identifier
(Loc, 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)));
Append_To (Outer_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 (Extra_Formal_Statements,
Make_Assignment_Statement (Loc,
Name =>
New_Occurrence_Of (Extra_Parameter, Loc),
Expression =>
PolyORB_Support.Helpers.Build_From_Any_Call (
Etype (Extra_Parameter),
New_Occurrence_Of (Extra_Any, Loc),
Decls)));
Set_Extra_Constrained (Object, Formal_Entity);
end;
end if;
end;
Next (Current_Parameter);
end loop;
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))));
Append_List_To (Statements, Extra_Formal_Statements);
if Nkind (Specification (Vis_Decl)) = N_Function_Specification then
-- The remote subprogram is a function. We build an inner block to
-- be able to hold a potentially unconstrained result in a
-- variable.
declare
Etyp : constant Entity_Id :=
Etype (Result_Definition (Specification (Vis_Decl)));
Result : constant Node_Id :=
Make_Defining_Identifier (Loc,
New_Internal_Name ('R'));
begin
Inner_Decls := New_List (
Make_Object_Declaration (Loc,
Defining_Identifier => Result,
Constant_Present => True,
Object_Definition => New_Occurrence_Of (Etyp, Loc),
Expression =>
Make_Function_Call (Loc,
Name => Called_Subprogram,
Parameter_Associations => Parameter_List)));
Set_Etype (Result, Etyp);
Append_To (After_Statements,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Set_Result), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Request_Parameter, Loc),
PolyORB_Support.Helpers.Build_To_Any_Call (
New_Occurrence_Of (Result, Loc),
Decls))));
-- A DSA function does not have out or inout arguments
end;
Append_To (Statements,
Make_Block_Statement (Loc,
Declarations => Inner_Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => After_Statements)));
else
-- The remote subprogram is a procedure. We do not need any inner
-- block in this case. No specific processing is required here for
-- the dynamically asynchronous case: the indication of whether
-- call is asynchronous or not is managed by the Sync_Scope
-- attibute of the request, and is handled entirely in the
-- protocol layer.
Append_To (After_Statements,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Request_Set_Out), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Request_Parameter, Loc))));
Append_To (Statements,
Make_Procedure_Call_Statement (Loc,
Name => Called_Subprogram,
Parameter_Associations => Parameter_List));
Append_List_To (Statements, After_Statements);
end if;
Subp_Spec :=
Make_Procedure_Specification (Loc,
Defining_Unit_Name =>
Make_Defining_Identifier (Loc, New_Internal_Name ('F')),
Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier => Request_Parameter,
Parameter_Type =>
New_Occurrence_Of (RTE (RE_Request_Access), Loc))));
-- An exception raised during the execution of an incoming
-- remote subprogram call and that needs to be sent back
-- to the caller is propagated by the receiving stubs, and
-- will be handled by the caller (the distribution runtime).
if Asynchronous and then not Dynamically_Asynchronous then
-- For an asynchronous procedure, add a null exception handler
Excep_Handlers := New_List (
Make_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 floarting
-- point type from Standard, or the smallest unsigned (modular) type
-- from System.Unsigned_Types, whose range encompasses that of Typ.
function Make_Stream_Procedure_Function_Name
(Loc : Source_Ptr;
Typ : Entity_Id;
Nam : Name_Id) return Entity_Id;
-- Return the name to be assigned for stream subprogram Nam of Typ.
-- (copied from exp_strm.adb, should be shared???)
------------------------------------------------------------
-- Common subprograms for building various tree fragments --
------------------------------------------------------------
function Build_Get_Aggregate_Element
(Loc : Source_Ptr;
Any : Entity_Id;
TC : Node_Id;
Idx : Node_Id) return Node_Id;
-- Build a call to Get_Aggregate_Element on Any
-- for typecode TC, returning the Idx'th element.
generic
Subprogram : Entity_Id;
-- Reference location for constructed nodes
Arry : Entity_Id;
-- For 'Range and Etype
Indices : List_Id;
-- For the construction of the innermost element expression
with procedure Add_Process_Element
(Stmts : List_Id;
Any : Entity_Id;
Counter : Entity_Id;
Datum : Node_Id);
procedure Append_Array_Traversal
(Stmts : List_Id;
Any : Entity_Id;
Counter : Entity_Id := Empty;
Depth : Pos := 1);
-- Build nested loop statements that iterate over the elements of an
-- array Arry. The statement(s) built by Add_Process_Element are
-- executed for each element; Indices is the list of indices to be
-- used in the construction of the indexed component that denotes the
-- current element. Subprogram is the entity for the subprogram for
-- which this iterator is generated. The generated statements are
-- appended to Stmts.
generic
Rec : Entity_Id;
-- The record entity being dealt with
with procedure Add_Process_Element
(Stmts : List_Id;
Container : Node_Or_Entity_Id;
Counter : in out Int;
Rec : Entity_Id;
Field : Node_Id);
-- Rec is the instance of the record type, or Empty.
-- Field is either the N_Defining_Identifier for a component,
-- or an N_Variant_Part.
procedure Append_Record_Traversal
(Stmts : List_Id;
Clist : Node_Id;
Container : Node_Or_Entity_Id;
Counter : in out Int);
-- Process component list Clist. Individual fields are passed
-- to Field_Processing. Each variant part is also processed.
-- Container is the outer Any (for From_Any/To_Any),
-- the outer typecode (for TC) to which the operation applies.
-----------------------------
-- Append_Record_Traversal --
-----------------------------
procedure Append_Record_Traversal
(Stmts : List_Id;
Clist : Node_Id;
Container : Node_Or_Entity_Id;
Counter : in out Int)
is
CI : constant List_Id := Component_Items (Clist);
VP : constant Node_Id := Variant_Part (Clist);
Item : Node_Id := First (CI);
Def : Entity_Id;
begin
while Present (Item) loop
Def := Defining_Identifier (Item);
if not Is_Internal_Name (Chars (Def)) then
Add_Process_Element
(Stmts, Container, Counter, Rec, Def);
end if;
Next (Item);
end loop;
if Present (VP) then
Add_Process_Element (Stmts, Container, Counter, Rec, VP);
end if;
end Append_Record_Traversal;
-------------------------
-- Build_From_Any_Call --
-------------------------
function Build_From_Any_Call
(Typ : Entity_Id;
N : Node_Id;
Decls : List_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (N);
U_Type : Entity_Id := Underlying_Type (Typ);
Fnam : Entity_Id := Empty;
Lib_RE : RE_Id := RE_Null;
begin
-- First simple case where the From_Any function is present
-- in the type's TSS.
Fnam := Find_Inherited_TSS (U_Type, TSS_From_Any);
if Sloc (U_Type) <= Standard_Location then
U_Type := Base_Type (U_Type);
end if;
-- Check first for Boolean and Character. These are enumeration
-- types, but we treat them specially, since they may require
-- special handling in the transfer protocol. However, this
-- special handling only applies if they have standard
-- representation, otherwise they are treated like any other
-- enumeration type.
if Present (Fnam) then
null;
elsif U_Type = Standard_Boolean then
Lib_RE := RE_FA_B;
elsif U_Type = Standard_Character then
Lib_RE := RE_FA_C;
elsif U_Type = Standard_Wide_Character then
Lib_RE := RE_FA_WC;
elsif U_Type = Standard_Wide_Wide_Character then
Lib_RE := RE_FA_WWC;
-- Floating point types
elsif U_Type = Standard_Short_Float then
Lib_RE := RE_FA_SF;
elsif U_Type = Standard_Float then
Lib_RE := RE_FA_F;
elsif U_Type = Standard_Long_Float then
Lib_RE := RE_FA_LF;
elsif U_Type = Standard_Long_Long_Float then
Lib_RE := RE_FA_LLF;
-- Integer types
elsif U_Type = Etype (Standard_Short_Short_Integer) then
Lib_RE := RE_FA_SSI;
elsif U_Type = Etype (Standard_Short_Integer) then
Lib_RE := RE_FA_SI;
elsif U_Type = Etype (Standard_Integer) then
Lib_RE := RE_FA_I;
elsif U_Type = Etype (Standard_Long_Integer) then
Lib_RE := RE_FA_LI;
elsif U_Type = Etype (Standard_Long_Long_Integer) then
Lib_RE := RE_FA_LLI;
-- Unsigned integer types
elsif U_Type = RTE (RE_Short_Short_Unsigned) then
Lib_RE := RE_FA_SSU;
elsif U_Type = RTE (RE_Short_Unsigned) then
Lib_RE := RE_FA_SU;
elsif U_Type = RTE (RE_Unsigned) then
Lib_RE := RE_FA_U;
elsif U_Type = RTE (RE_Long_Unsigned) then
Lib_RE := RE_FA_LU;
elsif U_Type = RTE (RE_Long_Long_Unsigned) then
Lib_RE := RE_FA_LLU;
elsif U_Type = Standard_String then
Lib_RE := RE_FA_String;
-- 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;
return
Make_Function_Call (Loc,
Name => New_Occurrence_Of (Fnam, Loc),
Parameter_Associations => New_List (N));
end Build_From_Any_Call;
-----------------------------
-- Build_From_Any_Function --
-----------------------------
procedure Build_From_Any_Function
(Loc : Source_Ptr;
Typ : Entity_Id;
Decl : out Node_Id;
Fnam : out Entity_Id)
is
Spec : Node_Id;
Decls : constant List_Id := New_List;
Stms : constant List_Id := New_List;
Any_Parameter : constant Entity_Id
:= Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
begin
Fnam := Make_Stream_Procedure_Function_Name (Loc,
Typ, Name_uFrom_Any);
Spec :=
Make_Function_Specification (Loc,
Defining_Unit_Name => Fnam,
Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier =>
Any_Parameter,
Parameter_Type =>
New_Occurrence_Of (RTE (RE_Any), Loc))),
Result_Definition => New_Occurrence_Of (Typ, Loc));
-- The following is taken care of by Exp_Dist.Add_RACW_From_Any
pragma Assert
(not (Is_Remote_Access_To_Class_Wide_Type (Typ)));
if Is_Derived_Type (Typ)
and then not Is_Tagged_Type (Typ)
then
Append_To (Stms,
Make_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_Return_Statement (Loc,
Expression =>
OK_Convert_To (
Typ,
Build_From_Any_Call (
Etype (Typ),
New_Occurrence_Of (Any_Parameter, Loc),
Decls))));
else
declare
Disc : Entity_Id := Empty;
Discriminant_Associations : List_Id;
Rdef : constant Node_Id :=
Type_Definition (Declaration_Node (Typ));
Component_Counter : Int := 0;
-- The returned object
Res : constant Entity_Id :=
Make_Defining_Identifier (Loc,
New_Internal_Name ('R'));
Res_Definition : Node_Id := New_Occurrence_Of (Typ, Loc);
procedure FA_Rec_Add_Process_Element
(Stmts : List_Id;
Any : Entity_Id;
Counter : in out Int;
Rec : Entity_Id;
Field : Node_Id);
procedure FA_Append_Record_Traversal is
new Append_Record_Traversal
(Rec => Res,
Add_Process_Element => FA_Rec_Add_Process_Element);
--------------------------------
-- FA_Rec_Add_Process_Element --
--------------------------------
procedure FA_Rec_Add_Process_Element
(Stmts : List_Id;
Any : Entity_Id;
Counter : in out Int;
Rec : Entity_Id;
Field : Node_Id)
is
begin
if Nkind (Field) = N_Defining_Identifier then
-- A regular component
Append_To (Stmts,
Make_Assignment_Statement (Loc,
Name => Make_Selected_Component (Loc,
Prefix =>
New_Occurrence_Of (Rec, Loc),
Selector_Name =>
New_Occurrence_Of (Field, Loc)),
Expression =>
Build_From_Any_Call (Etype (Field),
Build_Get_Aggregate_Element (Loc,
Any => Any,
-- LLVM local
TC => Build_TypeCode_Call (Loc,
Etype (Field), Decls),
Idx => Make_Integer_Literal (Loc,
Counter)),
Decls)));
else
-- A variant part
declare
Variant : Node_Id;
Struct_Counter : Int := 0;
Block_Decls : constant List_Id := New_List;
Block_Stmts : constant List_Id := New_List;
VP_Stmts : List_Id;
Alt_List : constant List_Id := New_List;
Choice_List : List_Id;
Struct_Any : constant Entity_Id :=
Make_Defining_Identifier (Loc,
New_Internal_Name ('S'));
begin
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier =>
Struct_Any,
Constant_Present =>
True,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Any), Loc),
Expression =>
Make_Function_Call (Loc,
Name => New_Occurrence_Of (
RTE (RE_Extract_Union_Value), Loc),
Parameter_Associations => New_List (
Build_Get_Aggregate_Element (Loc,
Any => Any,
-- LLVM local
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,
Counter))),
Idx => Make_Integer_Literal (Loc,
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;
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
Disc := First_Discriminant (Typ);
Discriminant_Associations := New_List;
while Present (Disc) loop
declare
Disc_Var_Name : constant Entity_Id :=
Make_Defining_Identifier (Loc, 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 (Etype (Disc),
Build_Get_Aggregate_Element (Loc,
Any => Any_Parameter,
-- LLVM local
TC => Build_TypeCode_Call
(Loc, Etype (Disc), Decls),
Idx => Make_Integer_Literal
(Loc, 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_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 : constant Node_Id :=
Build_Get_Aggregate_Element (Loc,
Any => Any,
-- LLVM local
TC => Build_TypeCode_Call (Loc,
Etype (Datum), Decls),
Idx => New_Occurrence_Of (Counter, Loc));
begin
-- 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;
Counter : constant Entity_Id :=
Make_Defining_Identifier (Loc, Name_J);
Initial_Counter_Value : Int := 0;
Component_TC : constant Entity_Id :=
Make_Defining_Identifier (Loc, Name_T);
Res : constant Entity_Id :=
Make_Defining_Identifier (Loc, Name_R);
procedure Append_From_Any_Array_Iterator is
new Append_Array_Traversal (
Subprogram => Fnam,
Arry => Res,
Indices => New_List,
Add_Process_Element => FA_Ary_Add_Process_Element);
Res_Subtype_Indication : Node_Id :=
New_Occurrence_Of (Typ, Loc);
begin
if not Constrained then
declare
Ndim : constant Int := Number_Dimensions (Typ);
Lnam : Name_Id;
Hnam : Name_Id;
Indx : Node_Id := First_Index (Typ);
Indt : Entity_Id;
Ranges : constant List_Id := New_List;
begin
for J in 1 .. Ndim loop
Lnam := New_External_Name ('L', J);
Hnam := New_External_Name ('H', J);
Indt := Etype (Indx);
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Lnam),
Constant_Present =>
True,
Object_Definition =>
New_Occurrence_Of (Indt, Loc),
Expression =>
Build_From_Any_Call (
Indt,
Build_Get_Aggregate_Element (Loc,
Any => Any_Parameter,
-- LLVM local
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 =>
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Indt, Loc),
Attribute_Name =>
Name_Pos,
Expressions => New_List (
Make_Identifier (Loc, Lnam))),
Right_Opnd =>
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,
J)))),
Right_Opnd =>
Make_Integer_Literal (Loc, 1))))));
Append_To (Ranges,
Make_Range (Loc,
Low_Bound => Make_Identifier (Loc, Lnam),
High_Bound => Make_Identifier (Loc, Hnam)));
Next_Index (Indx);
end loop;
-- Now we have all the necessary bound information:
-- apply the set of range constraints to the
-- (unconstrained) nominal subtype of Res.
Initial_Counter_Value := Ndim;
Res_Subtype_Indication := Make_Subtype_Indication (Loc,
Subtype_Mark =>
Res_Subtype_Indication,
Constraint =>
Make_Index_Or_Discriminant_Constraint (Loc,
Constraints => Ranges));
end;
end if;
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => Res,
Object_Definition => Res_Subtype_Indication));
Set_Etype (Res, Typ);
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => Counter,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Long_Unsigned), Loc),
Expression =>
Make_Integer_Literal (Loc, Initial_Counter_Value)));
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => Component_TC,
Constant_Present => True,
Object_Definition =>
New_Occurrence_Of (RTE (RE_TypeCode), Loc),
Expression =>
Build_TypeCode_Call (Loc,
Component_Type (Typ), Decls)));
Append_From_Any_Array_Iterator (Stms,
Any_Parameter, Counter);
Append_To (Stms,
Make_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_Return_Statement (Loc,
Expression =>
Unchecked_Convert_To (
Typ,
Build_From_Any_Call (
Find_Numeric_Representation (Typ),
New_Occurrence_Of (Any_Parameter, Loc),
Decls))));
else
-- Default: type is represented as an opaque sequence of bytes
declare
Strm : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('S'));
Res : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('R'));
begin
-- Strm : Buffer_Stream_Type;
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier =>
Strm,
Aliased_Present =>
True,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Buffer_Stream_Type), Loc)));
-- Any_To_BS (Strm, A);
Append_To (Stms,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Any_To_BS), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Any_Parameter, Loc),
New_Occurrence_Of (Strm, Loc))));
-- declare
-- Res : constant T := T'Input (Strm);
-- begin
-- Release_Buffer (Strm);
-- return Res;
-- end;
Append_To (Stms, Make_Block_Statement (Loc,
Declarations => New_List (
Make_Object_Declaration (Loc,
Defining_Identifier => Res,
Constant_Present => True,
Object_Definition =>
New_Occurrence_Of (Typ, Loc),
Expression =>
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Typ, Loc),
Attribute_Name => Name_Input,
Expressions => New_List (
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Strm, Loc),
Attribute_Name => Name_Access))))),
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Release_Buffer), Loc),
Parameter_Associations =>
New_List (
New_Occurrence_Of (Strm, Loc))),
Make_Return_Statement (Loc,
Expression => New_Occurrence_Of (Res, Loc))))));
end;
end if;
Decl :=
Make_Subprogram_Body (Loc,
Specification => Spec,
Declarations => Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Stms));
end Build_From_Any_Function;
---------------------------------
-- Build_Get_Aggregate_Element --
---------------------------------
function Build_Get_Aggregate_Element
(Loc : Source_Ptr;
Any : Entity_Id;
TC : Node_Id;
Idx : Node_Id) return Node_Id
is
begin
return Make_Function_Call (Loc,
Name =>
New_Occurrence_Of (
RTE (RE_Get_Aggregate_Element), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Any, Loc),
TC,
Idx));
end Build_Get_Aggregate_Element;
-------------------------
-- Build_Reposiroty_Id --
-------------------------
procedure Build_Name_And_Repository_Id
(E : Entity_Id;
Name_Str : out String_Id;
Repo_Id_Str : out String_Id)
is
begin
Start_String;
Store_String_Chars ("DSA:");
Get_Library_Unit_Name_String (Scope (E));
Store_String_Chars (
Name_Buffer (Name_Buffer'First
.. Name_Buffer'First + Name_Len - 1));
Store_String_Char ('.');
Get_Name_String (Chars (E));
Store_String_Chars (
Name_Buffer (Name_Buffer'First
.. Name_Buffer'First + Name_Len - 1));
Store_String_Chars (":1.0");
Repo_Id_Str := End_String;
Name_Str := String_From_Name_Buffer;
end Build_Name_And_Repository_Id;
-----------------------
-- Build_To_Any_Call --
-----------------------
function Build_To_Any_Call
(N : Node_Id;
Decls : List_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (N);
Typ : Entity_Id := Etype (N);
U_Type : Entity_Id;
Fnam : Entity_Id := Empty;
Lib_RE : RE_Id := RE_Null;
begin
-- If N is a selected component, then maybe its Etype
-- has not been set yet: try to use the 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));
-- The full view, if Typ is private; the completion,
-- if Typ is incomplete.
U_Type := Underlying_Type (Typ);
-- First simple case where the To_Any function is present
-- in the type's TSS.
Fnam := Find_Inherited_TSS (U_Type, TSS_To_Any);
-- Check first for Boolean and Character. These are enumeration
-- types, but we treat them specially, since they may require
-- special handling in the transfer protocol. However, this
-- special handling only applies if they have standard
-- representation, otherwise they are treated like any other
-- enumeration type.
if Sloc (U_Type) <= Standard_Location then
U_Type := Base_Type (U_Type);
end if;
if Present (Fnam) then
null;
elsif U_Type = Standard_Boolean then
Lib_RE := RE_TA_B;
elsif U_Type = Standard_Character then
Lib_RE := RE_TA_C;
elsif U_Type = Standard_Wide_Character then
Lib_RE := RE_TA_WC;
elsif U_Type = Standard_Wide_Wide_Character then
Lib_RE := RE_TA_WWC;
-- Floating point types
elsif U_Type = Standard_Short_Float then
Lib_RE := RE_TA_SF;
elsif U_Type = Standard_Float then
Lib_RE := RE_TA_F;
elsif U_Type = Standard_Long_Float then
Lib_RE := RE_TA_LF;
elsif U_Type = Standard_Long_Long_Float then
Lib_RE := RE_TA_LLF;
-- Integer types
elsif U_Type = Etype (Standard_Short_Short_Integer) then
Lib_RE := RE_TA_SSI;
elsif U_Type = Etype (Standard_Short_Integer) then
Lib_RE := RE_TA_SI;
elsif U_Type = Etype (Standard_Integer) then
Lib_RE := RE_TA_I;
elsif U_Type = Etype (Standard_Long_Integer) then
Lib_RE := RE_TA_LI;
elsif U_Type = Etype (Standard_Long_Long_Integer) then
Lib_RE := RE_TA_LLI;
-- Unsigned integer types
elsif U_Type = RTE (RE_Short_Short_Unsigned) then
Lib_RE := RE_TA_SSU;
elsif U_Type = RTE (RE_Short_Unsigned) then
Lib_RE := RE_TA_SU;
elsif U_Type = RTE (RE_Unsigned) then
Lib_RE := RE_TA_U;
elsif U_Type = RTE (RE_Long_Unsigned) then
Lib_RE := RE_TA_LU;
elsif U_Type = RTE (RE_Long_Long_Unsigned) then
Lib_RE := RE_TA_LLU;
elsif U_Type = Standard_String then
Lib_RE := RE_TA_String;
elsif U_Type = Underlying_Type (RTE (RE_TypeCode)) then
Lib_RE := RE_TA_TC;
-- Other (non-primitive) types
else
declare
Decl : Entity_Id;
begin
Build_To_Any_Function (Loc, U_Type, Decl, Fnam);
Append_To (Decls, Decl);
end;
end if;
-- Call the function
if Lib_RE /= RE_Null then
pragma Assert (No (Fnam));
Fnam := RTE (Lib_RE);
end if;
return
Make_Function_Call (Loc,
Name => New_Occurrence_Of (Fnam, Loc),
Parameter_Associations => New_List (N));
end Build_To_Any_Call;
---------------------------
-- Build_To_Any_Function --
---------------------------
procedure Build_To_Any_Function
(Loc : Source_Ptr;
Typ : Entity_Id;
Decl : out Node_Id;
Fnam : out Entity_Id)
is
Spec : Node_Id;
Decls : constant List_Id := New_List;
Stms : constant List_Id := New_List;
Expr_Parameter : constant Entity_Id :=
Make_Defining_Identifier (Loc, Name_E);
Any : constant Entity_Id :=
Make_Defining_Identifier (Loc, Name_A);
Any_Decl : Node_Id;
Result_TC : Node_Id := Build_TypeCode_Call (Loc, Typ, Decls);
begin
Fnam := Make_Stream_Procedure_Function_Name (Loc,
Typ, Name_uTo_Any);
Spec :=
Make_Function_Specification (Loc,
Defining_Unit_Name => Fnam,
Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier =>
Expr_Parameter,
Parameter_Type =>
New_Occurrence_Of (Typ, Loc))),
Result_Definition => New_Occurrence_Of (RTE (RE_Any), Loc));
Set_Etype (Expr_Parameter, Typ);
Any_Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier =>
Any,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Any), Loc));
if Is_Derived_Type (Typ) and then not Is_Tagged_Type (Typ) then
declare
Rt_Type : constant Entity_Id
:= Root_Type (Typ);
Expr : constant Node_Id
:= OK_Convert_To (
Rt_Type,
New_Occurrence_Of (Expr_Parameter, Loc));
begin
Set_Expression (Any_Decl, Build_To_Any_Call (Expr, Decls));
end;
elsif Is_Record_Type (Typ) and then not Is_Tagged_Type (Typ) then
if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then
declare
Rt_Type : constant Entity_Id
:= Etype (Typ);
Expr : constant Node_Id
:= OK_Convert_To (
Rt_Type,
New_Occurrence_Of (Expr_Parameter, Loc));
begin
Set_Expression (Any_Decl,
Build_To_Any_Call (Expr, Decls));
end;
else
declare
Disc : Entity_Id := Empty;
Rdef : constant Node_Id :=
Type_Definition (Declaration_Node (Typ));
Counter : Int := 0;
Elements : constant List_Id := New_List;
procedure TA_Rec_Add_Process_Element
(Stmts : List_Id;
Container : Node_Or_Entity_Id;
Counter : in out Int;
Rec : Entity_Id;
Field : Node_Id);
procedure TA_Append_Record_Traversal is
new Append_Record_Traversal
(Rec => Expr_Parameter,
Add_Process_Element => TA_Rec_Add_Process_Element);
--------------------------------
-- TA_Rec_Add_Process_Element --
--------------------------------
procedure TA_Rec_Add_Process_Element
(Stmts : List_Id;
Container : Node_Or_Entity_Id;
Counter : in out Int;
Rec : Entity_Id;
Field : Node_Id)
is
Field_Ref : Node_Id;
begin
if Nkind (Field) = N_Defining_Identifier then
-- A regular component
Field_Ref := Make_Selected_Component (Loc,
Prefix => New_Occurrence_Of (Rec, Loc),
Selector_Name => New_Occurrence_Of (Field, Loc));
Set_Etype (Field_Ref, Etype (Field));
Append_To (Stmts,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (
RTE (RE_Add_Aggregate_Element), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Any, Loc),
Build_To_Any_Call (Field_Ref, Decls))));
else
-- A variant part
declare
Variant : Node_Id;
Struct_Counter : Int := 0;
Block_Decls : constant List_Id := New_List;
Block_Stmts : constant List_Id := New_List;
VP_Stmts : List_Id;
Alt_List : constant List_Id := New_List;
Choice_List : List_Id;
Union_Any : constant Entity_Id :=
Make_Defining_Identifier (Loc,
New_Internal_Name ('U'));
Struct_Any : constant Entity_Id :=
Make_Defining_Identifier (Loc,
New_Internal_Name ('S'));
function Make_Discriminant_Reference
return Node_Id;
-- Build a selected component for the
-- discriminant of 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, Name (Field));
return Nod;
end Make_Discriminant_Reference;
begin
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_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)))))));
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_0)))))));
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;
TA_Append_Record_Traversal (
Stmts => VP_Stmts,
Clist => Component_List (Variant),
Container => Struct_Any,
Counter => Struct_Counter);
-- Append discriminant value and 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),
Build_To_Any_Call (
Make_Discriminant_Reference,
Block_Decls))));
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),
Make_Function_Call (Loc,
Name => New_Occurrence_Of (
RTE (RE_Any_Aggregate_Build), Loc),
Parameter_Associations => New_List (
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;
end if;
end TA_Rec_Add_Process_Element;
begin
-- First all discriminants
if Has_Discriminants (Typ) then
Disc := First_Discriminant (Typ);
while Present (Disc) loop
Append_To (Elements,
Make_Component_Association (Loc,
Choices => New_List (
Make_Integer_Literal (Loc, Counter)),
Expression =>
Build_To_Any_Call (
Make_Selected_Component (Loc,
Prefix => Expr_Parameter,
Selector_Name => Chars (Disc)),
Decls)));
Counter := Counter + 1;
Next_Discriminant (Disc);
end loop;
else
-- Make elements an empty array
declare
Dummy_Any : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('A'));
begin
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => Dummy_Any,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Any), Loc)));
Append_To (Elements,
Make_Component_Association (Loc,
Choices => New_List (
Make_Range (Loc,
Low_Bound =>
Make_Integer_Literal (Loc, 1),
High_Bound =>
Make_Integer_Literal (Loc, 0))),
Expression =>
New_Occurrence_Of (Dummy_Any, Loc)));
end;
end if;
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 all components
TA_Append_Record_Traversal (Stms,
Clist => Component_List (Rdef),
Container => Any,
Counter => Counter);
end;
end if;
elsif Is_Array_Type (Typ) then
declare
Constrained : constant Boolean := Is_Constrained (Typ);
procedure TA_Ary_Add_Process_Element
(Stmts : List_Id;
Any : Entity_Id;
Counter : Entity_Id;
Datum : Node_Id);
--------------------------------
-- TA_Ary_Add_Process_Element --
--------------------------------
procedure TA_Ary_Add_Process_Element
(Stmts : List_Id;
Any : Entity_Id;
Counter : Entity_Id;
Datum : Node_Id)
is
pragma Warnings (Off);
pragma Unreferenced (Counter);
pragma Warnings (On);
Element_Any : Node_Id;
begin
if Etype (Datum) = RTE (RE_Any) then
Element_Any := Datum;
else
Element_Any := Build_To_Any_Call (Datum, Decls);
end if;
Append_To (Stmts,
Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (
RTE (RE_Add_Aggregate_Element), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Any, Loc),
Element_Any)));
end TA_Ary_Add_Process_Element;
procedure Append_To_Any_Array_Iterator is
new Append_Array_Traversal (
Subprogram => Fnam,
Arry => Expr_Parameter,
Indices => New_List,
Add_Process_Element => TA_Ary_Add_Process_Element);
Index : Node_Id;
begin
Set_Expression (Any_Decl,
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Create_Any), Loc),
Parameter_Associations => New_List (Result_TC)));
Result_TC := Empty;
if not Constrained then
Index := First_Index (Typ);
for J in 1 .. Number_Dimensions (Typ) loop
Append_To (Stms,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (
RTE (RE_Add_Aggregate_Element), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Any, Loc),
Build_To_Any_Call (
OK_Convert_To (Etype (Index),
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Expr_Parameter, Loc),
Attribute_Name => Name_First,
Expressions => New_List (
Make_Integer_Literal (Loc, J)))),
Decls))));
Next_Index (Index);
end loop;
end if;
Append_To_Any_Array_Iterator (Stms, Any);
end;
elsif Is_Integer_Type (Typ) or else Is_Unsigned_Type (Typ) then
Set_Expression (Any_Decl,
Build_To_Any_Call (
OK_Convert_To (
Find_Numeric_Representation (Typ),
New_Occurrence_Of (Expr_Parameter, Loc)),
Decls));
else
-- Default: type is represented as an opaque sequence of bytes
declare
Strm : constant Entity_Id := Make_Defining_Identifier (Loc,
New_Internal_Name ('S'));
begin
-- 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)));
-- Allocate_Buffer (Strm);
Append_To (Stms,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Allocate_Buffer), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Strm, Loc))));
-- T'Output (Strm'Access, E);
Append_To (Stms,
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Typ, Loc),
Attribute_Name => Name_Output,
Expressions => New_List (
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Strm, Loc),
Attribute_Name => Name_Access),
New_Occurrence_Of (Expr_Parameter, Loc))));
-- 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))));
-- 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_Return_Statement (Loc,
Expression => New_Occurrence_Of (Any, Loc)));
Decl :=
Make_Subprogram_Body (Loc,
Specification => Spec,
Declarations => Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Stms));
end Build_To_Any_Function;
-------------------------
-- Build_TypeCode_Call --
-------------------------
function Build_TypeCode_Call
(Loc : Source_Ptr;
Typ : Entity_Id;
Decls : List_Id) return Node_Id
is
U_Type : Entity_Id := Underlying_Type (Typ);
-- The full view, if Typ is private; the completion,
-- if Typ is incomplete.
Fnam : Entity_Id := Empty;
Lib_RE : RE_Id := RE_Null;
Expr : Node_Id;
begin
-- Special case System.PolyORB.Interface.Any: its primitives have
-- not been set yet, so can't call Find_Inherited_TSS.
if Typ = RTE (RE_Any) then
Fnam := RTE (RE_TC_Any);
else
-- First simple case where the TypeCode is present
-- in the type's TSS.
Fnam := Find_Inherited_TSS (U_Type, TSS_TypeCode);
end if;
if No (Fnam) then
if Sloc (U_Type) <= Standard_Location then
-- Do not try to build alias typecodes for subtypes from
-- Standard.
U_Type := Base_Type (U_Type);
end if;
if U_Type = Standard_Boolean then
Lib_RE := RE_TC_B;
elsif U_Type = Standard_Character then
Lib_RE := RE_TC_C;
elsif U_Type = Standard_Wide_Character then
Lib_RE := RE_TC_WC;
elsif U_Type = Standard_Wide_Wide_Character then
Lib_RE := RE_TC_WWC;
-- Floating point types
elsif U_Type = Standard_Short_Float then
Lib_RE := RE_TC_SF;
elsif U_Type = Standard_Float then
Lib_RE := RE_TC_F;
elsif U_Type = Standard_Long_Float then
Lib_RE := RE_TC_LF;
elsif U_Type = Standard_Long_Long_Float then
Lib_RE := RE_TC_LLF;
-- Integer types (walk back to the base type)
elsif U_Type = Etype (Standard_Short_Short_Integer) then
Lib_RE := RE_TC_SSI;
elsif U_Type = Etype (Standard_Short_Integer) then
Lib_RE := RE_TC_SI;
elsif U_Type = Etype (Standard_Integer) then
Lib_RE := RE_TC_I;
elsif U_Type = Etype (Standard_Long_Integer) then
Lib_RE := RE_TC_LI;
elsif U_Type = Etype (Standard_Long_Long_Integer) then
Lib_RE := RE_TC_LLI;
-- Unsigned integer types
elsif U_Type = RTE (RE_Short_Short_Unsigned) then
Lib_RE := RE_TC_SSU;
elsif U_Type = RTE (RE_Short_Unsigned) then
Lib_RE := RE_TC_SU;
elsif U_Type = RTE (RE_Unsigned) then
Lib_RE := RE_TC_U;
elsif U_Type = RTE (RE_Long_Unsigned) then
Lib_RE := RE_TC_LU;
elsif U_Type = RTE (RE_Long_Long_Unsigned) then
Lib_RE := RE_TC_LLU;
elsif U_Type = Standard_String then
Lib_RE := RE_TC_String;
-- 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_Stream_Procedure_Function_Name (Loc,
Typ, Name_uTypeCode);
Parameters : List_Id;
procedure Add_String_Parameter
(S : String_Id;
Parameter_List : List_Id);
-- Add a literal for S to Parameters
procedure Add_TypeCode_Parameter
(TC_Node : Node_Id;
Parameter_List : List_Id);
-- Add the typecode for Typ to Parameters
procedure Add_Long_Parameter
(Expr_Node : Node_Id;
Parameter_List : List_Id);
-- Add a signed long integer expression to Parameters
procedure Initialize_Parameter_List
(Name_String : String_Id;
Repo_Id_String : String_Id;
Parameter_List : out List_Id);
-- Return a list that contains the first two parameters
-- for a parameterized typecode: name and repository id.
function Make_Constructed_TypeCode
(Kind : Entity_Id;
Parameters : List_Id) return Node_Id;
-- Call TC_Build with the given kind and parameters
procedure Return_Constructed_TypeCode (Kind : Entity_Id);
-- Make a return statement that calls TC_Build with the given
-- typecode kind, and the constructed parameters list.
procedure Return_Alias_TypeCode (Base_TypeCode : Node_Id);
-- Return a typecode that is a TC_Alias for the given typecode
--------------------------
-- Add_String_Parameter --
--------------------------
procedure Add_String_Parameter
(S : String_Id;
Parameter_List : List_Id)
is
begin
Append_To (Parameter_List,
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of (RTE (RE_TA_String), Loc),
Parameter_Associations => New_List (
Make_String_Literal (Loc, S))));
end Add_String_Parameter;
----------------------------
-- Add_TypeCode_Parameter --
----------------------------
procedure Add_TypeCode_Parameter
(TC_Node : Node_Id;
Parameter_List : List_Id)
is
begin
Append_To (Parameter_List,
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of (RTE (RE_TA_TC), Loc),
Parameter_Associations => New_List (
TC_Node)));
end Add_TypeCode_Parameter;
------------------------
-- Add_Long_Parameter --
------------------------
procedure Add_Long_Parameter
(Expr_Node : Node_Id;
Parameter_List : List_Id)
is
begin
Append_To (Parameter_List,
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of (RTE (RE_TA_LI), Loc),
Parameter_Associations => New_List (Expr_Node)));
end Add_Long_Parameter;
-------------------------------
-- Initialize_Parameter_List --
-------------------------------
procedure Initialize_Parameter_List
(Name_String : String_Id;
Repo_Id_String : String_Id;
Parameter_List : out List_Id)
is
begin
Parameter_List := New_List;
Add_String_Parameter (Name_String, Parameter_List);
Add_String_Parameter (Repo_Id_String, Parameter_List);
end Initialize_Parameter_List;
---------------------------
-- Return_Alias_TypeCode --
---------------------------
procedure Return_Alias_TypeCode
(Base_TypeCode : Node_Id)
is
begin
Add_TypeCode_Parameter (Base_TypeCode, Parameters);
Return_Constructed_TypeCode (RTE (RE_TC_Alias));
end Return_Alias_TypeCode;
-------------------------------
-- Make_Constructed_TypeCode --
-------------------------------
function Make_Constructed_TypeCode
(Kind : Entity_Id;
Parameters : List_Id) return Node_Id
is
Constructed_TC : constant Node_Id :=
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of (RTE (RE_TC_Build), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Kind, Loc),
Make_Aggregate (Loc,
Expressions => Parameters)));
begin
Set_Etype (Constructed_TC, RTE (RE_TypeCode));
return Constructed_TC;
end Make_Constructed_TypeCode;
---------------------------------
-- Return_Constructed_TypeCode --
---------------------------------
procedure Return_Constructed_TypeCode (Kind : Entity_Id) is
begin
Append_To (Stms,
Make_Return_Statement (Loc,
Expression =>
Make_Constructed_TypeCode (Kind, Parameters)));
end Return_Constructed_TypeCode;
------------------
-- Record types --
------------------
procedure TC_Rec_Add_Process_Element
(Params : List_Id;
Any : Entity_Id;
Counter : in out Int;
Rec : Entity_Id;
Field : Node_Id);
procedure TC_Append_Record_Traversal is
new Append_Record_Traversal (
Rec => Empty,
Add_Process_Element => TC_Rec_Add_Process_Element);
--------------------------------
-- TC_Rec_Add_Process_Element --
--------------------------------
procedure TC_Rec_Add_Process_Element
(Params : List_Id;
Any : Entity_Id;
Counter : in out Int;
Rec : Entity_Id;
Field : Node_Id)
is
pragma Warnings (Off);
pragma Unreferenced (Any, Counter, Rec);
pragma Warnings (On);
begin
if Nkind (Field) = N_Defining_Identifier then
-- A regular component
Add_TypeCode_Parameter (
Build_TypeCode_Call (Loc, Etype (Field), Decls), Params);
Get_Name_String (Chars (Field));
Add_String_Parameter (String_From_Name_Buffer, Params);
else
-- A variant part
declare
Discriminant_Type : constant Entity_Id :=
Etype (Name (Field));
Is_Enum : constant Boolean :=
Is_Enumeration_Type (Discriminant_Type);
Union_TC_Params : List_Id;
U_Name : constant Name_Id :=
New_External_Name (Chars (Typ), 'U', -1);
Name_Str : String_Id;
Struct_TC_Params : List_Id;
Variant : Node_Id;
Choice : Node_Id;
Default : constant Node_Id :=
Make_Integer_Literal (Loc, -1);
Dummy_Counter : Int := 0;
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/varibles, then
-- subprogram specs, then subprogram bodies ???
---------------------------------------
-- Add_Params_For_Variant_Components --
---------------------------------------
procedure Add_Params_For_Variant_Components
is
S_Name : constant Name_Id :=
New_External_Name (U_Name, 'S', -1);
begin
Get_Name_String (S_Name);
Name_Str := String_From_Name_Buffer;
Initialize_Parameter_List
(Name_Str, Name_Str, Struct_TC_Params);
-- Build struct parameters
TC_Append_Record_Traversal (Struct_TC_Params,
Component_List (Variant),
Empty,
Dummy_Counter);
Add_TypeCode_Parameter
(Make_Constructed_TypeCode
(RTE (RE_TC_Struct), Struct_TC_Params),
Union_TC_Params);
Add_String_Parameter (Name_Str, Union_TC_Params);
end Add_Params_For_Variant_Components;
begin
Get_Name_String (U_Name);
Name_Str := String_From_Name_Buffer;
Initialize_Parameter_List
(Name_Str, Name_Str, Union_TC_Params);
Add_String_Parameter (Name_Str, Params);
-- Add union in enclosing parameter list
Add_TypeCode_Parameter
(Make_Constructed_TypeCode
(RTE (RE_TC_Union), Union_TC_Params),
Parameters);
-- Build union parameters
Add_TypeCode_Parameter
(Discriminant_Type, Union_TC_Params);
Add_Long_Parameter (Default, Union_TC_Params);
Variant := First_Non_Pragma (Variants (Field));
while Present (Variant) loop
Choice := First (Discrete_Choices (Variant));
while Present (Choice) loop
case Nkind (Choice) is
when N_Range =>
declare
L : constant Uint :=
Expr_Value (Low_Bound (Choice));
H : constant Uint :=
Expr_Value (High_Bound (Choice));
J : Uint := L;
-- 3.8.1(8) guarantees that the bounds of
-- this range are static.
Expr : Node_Id;
begin
while J <= H loop
if Is_Enum then
Expr := New_Occurrence_Of (
Get_Enum_Lit_From_Pos (
Discriminant_Type, J, Loc), Loc);
else
Expr :=
Make_Integer_Literal (Loc, J);
end if;
Append_To (Union_TC_Params,
Build_To_Any_Call (Expr, Decls));
Add_Params_For_Variant_Components;
J := J + Uint_1;
end loop;
end;
when N_Others_Choice =>
Add_Long_Parameter (
Make_Integer_Literal (Loc, 0),
Union_TC_Params);
Add_Params_For_Variant_Components;
when others =>
Append_To (Union_TC_Params,
Build_To_Any_Call (Choice, Decls));
Add_Params_For_Variant_Components;
end case;
end loop;
Next_Non_Pragma (Variant);
end loop;
end;
end if;
end TC_Rec_Add_Process_Element;
Type_Name_Str : String_Id;
Type_Repo_Id_Str : String_Id;
begin
pragma Assert (not Is_Itype (Typ));
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 Is_Derived_Type (Typ)
and then not Is_Tagged_Type (Typ)
then
declare
Parent_Type : Entity_Id := Etype (Typ);
begin
if Is_Itype (Parent_Type) then
-- Skip implicit base type
Parent_Type := Etype (Parent_Type);
end if;
Return_Alias_TypeCode (
Build_TypeCode_Call (Loc, Parent_Type, Decls));
end;
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
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
-- First all discriminants
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 all components
TC_Append_Record_Traversal
(Parameters, Component_List (Rdef),
Empty, Dummy_Counter);
Return_Constructed_TypeCode (RTE (RE_TC_Struct));
end;
end if;
elsif Is_Array_Type (Typ) then
declare
Ndim : constant Pos := Number_Dimensions (Typ);
Inner_TypeCode : Node_Id;
Constrained : constant Boolean := Is_Constrained (Typ);
Indx : Node_Id := First_Index (Typ);
begin
Inner_TypeCode := Build_TypeCode_Call (Loc,
Component_Type (Typ),
Decls);
for J in 1 .. Ndim loop
if Constrained then
Inner_TypeCode := Make_Constructed_TypeCode
(RTE (RE_TC_Array), New_List (
Build_To_Any_Call (
OK_Convert_To (RTE (RE_Long_Unsigned),
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Typ, Loc),
Attribute_Name =>
Name_Length,
Expressions => New_List (
Make_Integer_Literal (Loc,
Ndim - J + 1)))),
Decls),
Build_To_Any_Call (Inner_TypeCode, Decls)));
else
-- Unconstrained case: add low bound for each
-- dimension.
Add_TypeCode_Parameter
(Build_TypeCode_Call (Loc, Etype (Indx), Decls),
Parameters);
Get_Name_String (New_External_Name ('L', J));
Add_String_Parameter (
String_From_Name_Buffer,
Parameters);
Next_Index (Indx);
Inner_TypeCode := Make_Constructed_TypeCode
(RTE (RE_TC_Sequence), New_List (
Build_To_Any_Call (
OK_Convert_To (RTE (RE_Long_Unsigned),
Make_Integer_Literal (Loc, 0)),
Decls),
Build_To_Any_Call (Inner_TypeCode, Decls)));
end if;
end loop;
if Constrained then
Return_Alias_TypeCode (Inner_TypeCode);
else
Add_TypeCode_Parameter (Inner_TypeCode, Parameters);
Start_String;
Store_String_Char ('V');
Add_String_Parameter (End_String, Parameters);
Return_Constructed_TypeCode (RTE (RE_TC_Struct));
end if;
end;
else
-- Default: type is represented as an opaque sequence of bytes
Return_Alias_TypeCode
(New_Occurrence_Of (RTE (RE_TC_Opaque), Loc));
end if;
Decl :=
Make_Subprogram_Body (Loc,
Specification => Spec,
Declarations => Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Stms));
end Build_TypeCode_Function;
---------------------------------
-- Find_Numeric_Representation --
---------------------------------
function Find_Numeric_Representation
(Typ : Entity_Id) return Entity_Id
is
FST : constant Entity_Id := First_Subtype (Typ);
P_Size : constant Uint := Esize (FST);
begin
if Is_Unsigned_Type (Typ) then
if P_Size <= Standard_Short_Short_Integer_Size then
return RTE (RE_Short_Short_Unsigned);
elsif P_Size <= Standard_Short_Integer_Size then
return RTE (RE_Short_Unsigned);
elsif P_Size <= Standard_Integer_Size then
return RTE (RE_Unsigned);
elsif P_Size <= Standard_Long_Integer_Size then
return RTE (RE_Long_Unsigned);
else
return RTE (RE_Long_Long_Unsigned);
end if;
elsif Is_Integer_Type (Typ) then
if P_Size <= Standard_Short_Short_Integer_Size then
return Standard_Short_Short_Integer;
elsif P_Size <= Standard_Short_Integer_Size then
return Standard_Short_Integer;
elsif P_Size <= Standard_Integer_Size then
return Standard_Integer;
elsif P_Size <= Standard_Long_Integer_Size then
return Standard_Long_Integer;
else
return Standard_Long_Long_Integer;
end if;
elsif Is_Floating_Point_Type (Typ) then
if P_Size <= Standard_Short_Float_Size then
return Standard_Short_Float;
elsif P_Size <= Standard_Float_Size then
return Standard_Float;
elsif P_Size <= Standard_Long_Float_Size then
return Standard_Long_Float;
else
return Standard_Long_Long_Float;
end if;
else
raise Program_Error;
end if;
-- TBD: fixed point types???
-- TBverified numeric types with a biased representation???
end Find_Numeric_Representation;
---------------------------
-- Append_Array_Traversal --
---------------------------
procedure Append_Array_Traversal
(Stmts : List_Id;
Any : Entity_Id;
Counter : Entity_Id := Empty;
Depth : Pos := 1)
is
Loc : constant Source_Ptr := Sloc (Subprogram);
Typ : constant Entity_Id := Etype (Arry);
Constrained : constant Boolean := Is_Constrained (Typ);
Ndim : constant Pos := Number_Dimensions (Typ);
Inner_Any, Inner_Counter : Entity_Id;
Loop_Stm : Node_Id;
Inner_Stmts : constant List_Id := New_List;
begin
if Depth > Ndim then
-- Processing for one element of an array
declare
Element_Expr : constant Node_Id :=
Make_Indexed_Component (Loc,
New_Occurrence_Of (Arry, Loc),
Indices);
begin
Set_Etype (Element_Expr, Component_Type (Typ));
Add_Process_Element (Stmts,
Any => Any,
Counter => Counter,
Datum => Element_Expr);
end;
return;
end if;
Append_To (Indices,
Make_Identifier (Loc, New_External_Name ('L', Depth)));
if not Constrained or else Depth > 1 then
Inner_Any := Make_Defining_Identifier (Loc,
New_External_Name ('A', Depth));
Set_Etype (Inner_Any, RTE (RE_Any));
else
Inner_Any := Empty;
end if;
if Present (Counter) then
Inner_Counter := Make_Defining_Identifier (Loc,
New_External_Name ('J', Depth));
else
Inner_Counter := Empty;
end if;
declare
Loop_Any : Node_Id := Inner_Any;
begin
-- For the first dimension of a constrained array, we add
-- elements directly in the corresponding Any; there is no
-- intervening inner Any.
if No (Loop_Any) then
Loop_Any := Any;
end if;
Append_Array_Traversal (Inner_Stmts,
Any => Loop_Any,
Counter => Inner_Counter,
Depth => Depth + 1);
end;
Loop_Stm :=
Make_Implicit_Loop_Statement (Subprogram,
Iteration_Scheme =>
Make_Iteration_Scheme (Loc,
Loop_Parameter_Specification =>
Make_Loop_Parameter_Specification (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc,
Chars => New_External_Name ('L', Depth)),
Discrete_Subtype_Definition =>
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Arry, Loc),
Attribute_Name => Name_Range,
Expressions => New_List (
Make_Integer_Literal (Loc, Depth))))),
Statements => Inner_Stmts);
declare
Decls : constant List_Id := New_List;
Dimen_Stmts : constant List_Id := New_List;
Length_Node : Node_Id;
Inner_Any_TypeCode : constant Entity_Id :=
Make_Defining_Identifier (Loc,
New_External_Name ('T', Depth));
Inner_Any_TypeCode_Expr : Node_Id;
begin
if Depth = 1 then
if Constrained then
Inner_Any_TypeCode_Expr :=
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Get_TC), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Any, Loc)));
else
Inner_Any_TypeCode_Expr :=
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Any_Member_Type), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Any, Loc),
Make_Integer_Literal (Loc, Ndim)));
end if;
else
Inner_Any_TypeCode_Expr :=
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Content_Type), Loc),
Parameter_Associations => New_List (
Make_Identifier (Loc,
New_External_Name ('T', Depth - 1))));
end if;
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => Inner_Any_TypeCode,
Constant_Present => True,
Object_Definition => New_Occurrence_Of (
RTE (RE_TypeCode), Loc),
Expression => Inner_Any_TypeCode_Expr));
if Present (Inner_Any) then
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => Inner_Any,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Any), Loc),
Expression =>
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of (
RTE (RE_Create_Any), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Inner_Any_TypeCode, Loc)))));
end if;
if Present (Inner_Counter) then
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => Inner_Counter,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Long_Unsigned), Loc),
Expression =>
Make_Integer_Literal (Loc, 0)));
end if;
if not Constrained then
Length_Node := Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Arry, Loc),
Attribute_Name => Name_Length,
Expressions =>
New_List (Make_Integer_Literal (Loc, Depth)));
Set_Etype (Length_Node, RTE (RE_Long_Unsigned));
Add_Process_Element (Dimen_Stmts,
Datum => Length_Node,
Any => Inner_Any,
Counter => Inner_Counter);
end if;
-- Loop_Stm does approrpriate 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_Stream_Procedure_Function_Name --
-----------------------------------------
function Make_Stream_Procedure_Function_Name
(Loc : Source_Ptr;
Typ : Entity_Id;
Nam : Name_Id) return Entity_Id
is
begin
-- For tagged types, we use a canonical name so that it matches
-- the primitive spec. For all other cases, we use a serialized
-- name so that multiple generations of the same procedure do not
-- clash.
if Is_Tagged_Type (Typ) then
return Make_Defining_Identifier (Loc, Nam);
else
return Make_Defining_Identifier (Loc,
Chars =>
New_External_Name (Nam, ' ', Increment_Serial_Number));
end if;
end Make_Stream_Procedure_Function_Name;
end Helpers;
-----------------------------------
-- Reserve_NamingContext_Methods --
-----------------------------------
procedure Reserve_NamingContext_Methods is
Str_Resolve : constant String := "resolve";
begin
Name_Buffer (1 .. Str_Resolve'Length) := Str_Resolve;
Name_Len := Str_Resolve'Length;
Overload_Counter_Table.Set (Name_Find, 1);
end Reserve_NamingContext_Methods;
end PolyORB_Support;
-------------------------------
-- RACW_Type_Is_Asynchronous --
-------------------------------
procedure RACW_Type_Is_Asynchronous (RACW_Type : Entity_Id) is
Asynchronous_Flag : constant Entity_Id :=
Asynchronous_Flags_Table.Get (RACW_Type);
begin
Replace (Expression (Parent (Asynchronous_Flag)),
New_Occurrence_Of (Standard_True, Sloc (Asynchronous_Flag)));
end RACW_Type_Is_Asynchronous;
-------------------------
-- RCI_Package_Locator --
-------------------------
function RCI_Package_Locator
(Loc : Source_Ptr;
Package_Spec : Node_Id) return Node_Id
is
Inst : Node_Id;
Pkg_Name : String_Id;
begin
Get_Library_Unit_Name_String (Package_Spec);
Pkg_Name := String_From_Name_Buffer;
Inst :=
Make_Package_Instantiation (Loc,
Defining_Unit_Name =>
Make_Defining_Identifier (Loc, New_Internal_Name ('R')),
Name =>
New_Occurrence_Of (RTE (RE_RCI_Locator), Loc),
Generic_Associations => New_List (
Make_Generic_Association (Loc,
Selector_Name =>
Make_Identifier (Loc, Name_RCI_Name),
Explicit_Generic_Actual_Parameter =>
Make_String_Literal (Loc,
Strval => Pkg_Name))));
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
if Stub_Elements /= Empty_Stub_Structure then
Add_RACW_Primitive_Declarations_And_Bodies
(Full_View,
Stub_Elements.RPC_Receiver_Decl,
List_Containing (Declaration_Node (Full_View)));
end if;
end Remote_Types_Tagged_Full_View_Encountered;
-------------------
-- Scope_Of_Spec --
-------------------
function Scope_Of_Spec (Spec : Node_Id) return Entity_Id is
Unit_Name : Node_Id;
begin
Unit_Name := Defining_Unit_Name (Spec);
while Nkind (Unit_Name) /= N_Defining_Identifier loop
Unit_Name := Defining_Identifier (Unit_Name);
end loop;
return Unit_Name;
end Scope_Of_Spec;
----------------------
-- Set_Renaming_TSS --
----------------------
procedure Set_Renaming_TSS
(Typ : Entity_Id;
Nam : Entity_Id;
TSS_Nam : TSS_Name_Type)
is
Loc : constant Source_Ptr := Sloc (Nam);
Spec : constant Node_Id := Parent (Nam);
TSS_Node : constant Node_Id :=
Make_Subprogram_Renaming_Declaration (Loc,
Specification =>
Copy_Specification (Loc,
Spec => Spec,
New_Name => Make_TSS_Name (Typ, TSS_Nam)),
Name => New_Occurrence_Of (Nam, Loc));
Snam : constant Entity_Id :=
Defining_Unit_Name (Specification (TSS_Node));
begin
if Nkind (Spec) = N_Function_Specification then
Set_Ekind (Snam, E_Function);
Set_Etype (Snam, Entity (Result_Definition (Spec)));
else
Set_Ekind (Snam, E_Procedure);
Set_Etype (Snam, Standard_Void_Type);
end if;
Set_TSS (Typ, Snam);
end Set_Renaming_TSS;
----------------------------------------------
-- Specific_Add_Obj_RPC_Receiver_Completion --
----------------------------------------------
procedure Specific_Add_Obj_RPC_Receiver_Completion
(Loc : Source_Ptr;
Decls : List_Id;
RPC_Receiver : Entity_Id;
Stub_Elements : Stub_Structure) is
begin
case Get_PCS_Name is
when Name_PolyORB_DSA =>
PolyORB_Support.Add_Obj_RPC_Receiver_Completion (Loc,
Decls, RPC_Receiver, Stub_Elements);
when others =>
GARLIC_Support.Add_Obj_RPC_Receiver_Completion (Loc,
Decls, RPC_Receiver, Stub_Elements);
end case;
end Specific_Add_Obj_RPC_Receiver_Completion;
--------------------------------
-- Specific_Add_RACW_Features --
--------------------------------
procedure Specific_Add_RACW_Features
(RACW_Type : Entity_Id;
Desig : Entity_Id;
Stub_Type : Entity_Id;
Stub_Type_Access : Entity_Id;
RPC_Receiver_Decl : Node_Id;
Declarations : 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,
Declarations);
when others =>
GARLIC_Support.Add_RACW_Features (
RACW_Type,
Stub_Type,
Stub_Type_Access,
RPC_Receiver_Decl,
Declarations);
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)
is
begin
case Get_PCS_Name is
when Name_PolyORB_DSA =>
PolyORB_Support.Add_Receiving_Stubs_To_Declarations (
Pkg_Spec, Decls);
when others =>
GARLIC_Support.Add_Receiving_Stubs_To_Declarations (
Pkg_Spec, Decls);
end case;
end Specific_Add_Receiving_Stubs_To_Declarations;
------------------------------------------
-- Specific_Build_General_Calling_Stubs --
------------------------------------------
procedure Specific_Build_General_Calling_Stubs
(Decls : List_Id;
Statements : List_Id;
Target : RPC_Target;
Subprogram_Id : Node_Id;
Asynchronous : Node_Id := Empty;
Is_Known_Asynchronous : Boolean := False;
Is_Known_Non_Asynchronous : Boolean := False;
Is_Function : Boolean;
Spec : Node_Id;
Stub_Type : Entity_Id := Empty;
RACW_Type : Entity_Id := Empty;
Nod : Node_Id)
is
begin
case Get_PCS_Name is
when Name_PolyORB_DSA =>
PolyORB_Support.Build_General_Calling_Stubs (
Decls,
Statements,
Target.Object,
Subprogram_Id,
Asynchronous,
Is_Known_Asynchronous,
Is_Known_Non_Asynchronous,
Is_Function,
Spec,
Stub_Type,
RACW_Type,
Nod);
when others =>
GARLIC_Support.Build_General_Calling_Stubs (
Decls,
Statements,
Target.Partition,
Target.RPC_Receiver,
Subprogram_Id,
Asynchronous,
Is_Known_Asynchronous,
Is_Known_Non_Asynchronous,
Is_Function,
Spec,
Stub_Type,
RACW_Type,
Nod);
end case;
end Specific_Build_General_Calling_Stubs;
--------------------------------------
-- Specific_Build_RPC_Receiver_Body --
--------------------------------------
procedure Specific_Build_RPC_Receiver_Body
(RPC_Receiver : Entity_Id;
Request : out Entity_Id;
Subp_Id : out Entity_Id;
Subp_Index : out Entity_Id;
Stmts : out List_Id;
Decl : out Node_Id)
is
begin
case Get_PCS_Name is
when Name_PolyORB_DSA =>
PolyORB_Support.Build_RPC_Receiver_Body
(RPC_Receiver,
Request,
Subp_Id,
Subp_Index,
Stmts,
Decl);
when others =>
GARLIC_Support.Build_RPC_Receiver_Body
(RPC_Receiver,
Request,
Subp_Id,
Subp_Index,
Stmts,
Decl);
end case;
end Specific_Build_RPC_Receiver_Body;
--------------------------------
-- Specific_Build_Stub_Target --
--------------------------------
function Specific_Build_Stub_Target
(Loc : Source_Ptr;
Decls : List_Id;
RCI_Locator : Entity_Id;
Controlling_Parameter : Entity_Id) return RPC_Target
is
begin
case Get_PCS_Name is
when Name_PolyORB_DSA =>
return PolyORB_Support.Build_Stub_Target (Loc,
Decls, RCI_Locator, Controlling_Parameter);
when others =>
return GARLIC_Support.Build_Stub_Target (Loc,
Decls, RCI_Locator, Controlling_Parameter);
end case;
end Specific_Build_Stub_Target;
------------------------------
-- Specific_Build_Stub_Type --
------------------------------
procedure Specific_Build_Stub_Type
(RACW_Type : Entity_Id;
Stub_Type : Entity_Id;
Stub_Type_Decl : out Node_Id;
RPC_Receiver_Decl : out Node_Id)
is
begin
case Get_PCS_Name is
when Name_PolyORB_DSA =>
PolyORB_Support.Build_Stub_Type (
RACW_Type, Stub_Type,
Stub_Type_Decl, RPC_Receiver_Decl);
when others =>
GARLIC_Support.Build_Stub_Type (
RACW_Type, Stub_Type,
Stub_Type_Decl, RPC_Receiver_Decl);
end case;
end Specific_Build_Stub_Type;
function Specific_Build_Subprogram_Receiving_Stubs
(Vis_Decl : Node_Id;
Asynchronous : Boolean;
Dynamically_Asynchronous : Boolean := False;
Stub_Type : Entity_Id := Empty;
RACW_Type : Entity_Id := Empty;
Parent_Primitive : Entity_Id := Empty) return Node_Id
is
begin
case Get_PCS_Name is
when Name_PolyORB_DSA =>
return PolyORB_Support.Build_Subprogram_Receiving_Stubs (
Vis_Decl,
Asynchronous,
Dynamically_Asynchronous,
Stub_Type,
RACW_Type,
Parent_Primitive);
when others =>
return GARLIC_Support.Build_Subprogram_Receiving_Stubs (
Vis_Decl,
Asynchronous,
Dynamically_Asynchronous,
Stub_Type,
RACW_Type,
Parent_Primitive);
end case;
end Specific_Build_Subprogram_Receiving_Stubs;
--------------------------
-- 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;