-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2010, 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- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING. If not, write --
--- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
--- Boston, MA 02110-1301, USA. --
+-- Public License distributed with GNAT; see file COPYING3. If not, go to --
+-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-with Atree; use Atree;
-with Einfo; use Einfo;
-with Elists; use Elists;
-with Exp_Strm; use Exp_Strm;
-with Exp_Tss; use Exp_Tss;
-with Exp_Util; use Exp_Util;
+with Atree; use Atree;
+with Einfo; use Einfo;
+with Elists; use Elists;
+with Exp_Atag; use Exp_Atag;
+with Exp_Disp; use Exp_Disp;
+with Exp_Strm; use Exp_Strm;
+with Exp_Tss; use Exp_Tss;
+with Exp_Util; use Exp_Util;
+with Lib; use Lib;
+with Nlists; use Nlists;
+with Nmake; use Nmake;
+with Opt; use Opt;
+with Rtsfind; use Rtsfind;
+with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
+with Sem_Cat; use Sem_Cat;
+with Sem_Ch3; use Sem_Ch3;
+with Sem_Ch8; use Sem_Ch8;
+with Sem_Ch12; use Sem_Ch12;
+with Sem_Dist; use Sem_Dist;
+with Sem_Eval; use Sem_Eval;
+with Sem_Util; use Sem_Util;
+with Sinfo; use Sinfo;
+with Stand; use Stand;
+with Stringt; use Stringt;
+with Tbuild; use Tbuild;
+with Ttypes; use Ttypes;
+with Uintp; use Uintp;
+
with GNAT.HTable; use GNAT.HTable;
-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:
+ -- 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...]
-- 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
+ -- 1) Since it has the same structure as RACW_Stub_Type, it can
+ -- be converted to and from this type to make it suitable for
-- System.Partition_Interface.Get_Unique_Remote_Pointer in order
- -- to avoid memory leaks when the same remote object arrive on the
+ -- to avoid memory leaks when the same remote object arrives on the
-- same partition through several paths;
-- 2) It also has the same dispatching table as the designated type D,
-- 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.)
+ -- (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;
-----------------------
function Hash (F : Entity_Id) return Hash_Index;
- -- DSA expansion associates stubs to distributed object types using
- -- a hash table on entity ids.
+ -- DSA expansion associates stubs to distributed object types using a hash
+ -- table on entity ids.
- function Hash (F : Name_Id) return Hash_Index;
+ 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.
+ -- to be associated with each remote subprogram name. These counters are
+ -- maintained in a hash table on name ids.
type Subprogram_Identifiers is record
Str_Identifier : String_Id;
Key => Entity_Id,
Hash => Hash,
Equal => "=");
- -- Mapping between a remote subprogram and the corresponding
- -- subprogram identifiers.
+ -- Mapping between a remote subprogram and the corresponding subprogram
+ -- identifiers.
package Overload_Counter_Table is
new Simple_HTable (Header_Num => Hash_Index,
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).
+ -- 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;
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.
+ -- Add the proxy type required, on the receiving (server) side, to handle
+ -- calls to the subprogram declared by Vis_Decl through a remote access
+ -- to subprogram type. All_Calls_Remote_E must be Standard_True if a pragma
+ -- All_Calls_Remote applies, Standard_False otherwise. The new proxy type
+ -- is appended to Decls. Proxy_Object_Addr is a constant of type
+ -- System.Address that designates an instance of the proxy object.
function Build_Remote_Subprogram_Proxy_Type
(Loc : Source_Ptr;
ACR_Expression : Node_Id) return Node_Id;
- -- Build and return a tagged record type definition for an RCI
- -- subprogram proxy type.
- -- ACR_Expression is use as the initialization value for
- -- the All_Calls_Remote component.
+ -- Build and return a tagged record type definition for an RCI subprogram
+ -- proxy type. ACR_Expression is used as the initialization value for the
+ -- All_Calls_Remote component.
function Build_Get_Unique_RP_Call
(Loc : Source_Ptr;
-- tag fixup (Get_Unique_Remote_Pointer may have changed Pointer'Tag to
-- RACW_Stub_Type'Tag, while the desired tag is that of Stub_Type).
+ function Build_Stub_Tag
+ (Loc : Source_Ptr;
+ RACW_Type : Entity_Id) return Node_Id;
+ -- Return an expression denoting the tag of the stub type associated with
+ -- RACW_Type.
+
function Build_Subprogram_Calling_Stubs
(Vis_Decl : Node_Id;
Subp_Id : Node_Id;
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.
+ -- 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;
-- 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);
+ function Transmit_As_Unconstrained (Typ : Entity_Id) return Boolean;
+ -- True when Typ is an unconstrained type, or a null-excluding access type.
+ -- In either case, this means stubs cannot contain a default-initialized
+ -- object declaration of such type.
+
+ procedure Add_Calling_Stubs_To_Declarations (Pkg_Spec : Node_Id);
-- Add calling stubs to the declarative part
function Could_Be_Asynchronous (Spec : Node_Id) return Boolean;
-- Return True if nothing prevents the program whose specification is
- -- given to be asynchronous (i.e. no out parameter).
+ -- given to be asynchronous (i.e. no [IN] OUT parameters).
function Pack_Entity_Into_Stream_Access
(Loc : Source_Ptr;
(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.
+ -- 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
(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.
+ -- 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;
+ (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.
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.
+ -- Return a call to Add_Item to add the Any corresponding to the designated
+ -- formal Parameter (with the indicated Constrained status) to NVList.
+ -- RACW_Ctrl must be set to True for controlling formals of distributed
+ -- object primitive operations.
+
+ --------------------
+ -- Stub_Structure --
+ --------------------
+
+ -- This record describes various tree fragments associated with the
+ -- generation of RACW calling stubs. One such record exists for every
+ -- distributed object type, i.e. each tagged type that is the designated
+ -- type of one or more RACW type.
type Stub_Structure is record
Stub_Type : Entity_Id;
+ -- Stub type: this type has the same primitive operations as the
+ -- designated types, but the provided bodies for these operations
+ -- a remote call to an actual target object potentially located on
+ -- another partition; each value of the stub type encapsulates a
+ -- reference to a remote object.
+
Stub_Type_Access : Entity_Id;
+ -- A local access type designating the stub type (this is not an RACW
+ -- type).
+
RPC_Receiver_Decl : Node_Id;
+ -- Declaration for the RPC receiver entity associated with the
+ -- designated type. As an exception, for the case of an RACW that
+ -- implements a RAS, no object RPC receiver is generated. Instead,
+ -- RPC_Receiver_Decl is the declaration after which the RPC receiver
+ -- would have been inserted.
+
+ Body_Decls : List_Id;
+ -- List of subprogram bodies to be included in generated code: bodies
+ -- for the RACW's stream attributes, and for the primitive operations
+ -- of the stub type.
+
RACW_Type : Entity_Id;
+ -- One of the RACW types designating this distributed object type
+ -- (they are all interchangeable; we use any one of them in order to
+ -- avoid having to create various anonymous access types).
+
end record;
- -- 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);
+ (Empty, Empty, Empty, No_List, Empty);
package Stubs_Table is
new Simple_HTable (Header_Num => Hash_Index,
Equal => "=");
-- Mapping between a RCI subprogram and the corresponding calling stubs
+ function Get_Stub_Elements (RACW_Type : Entity_Id) return Stub_Structure;
+ -- Return the stub information associated with the given RACW type
+
procedure Add_Stub_Type
(Designated_Type : Entity_Id;
RACW_Type : Entity_Id;
Stub_Type : out Entity_Id;
Stub_Type_Access : out Entity_Id;
RPC_Receiver_Decl : out Node_Id;
+ Body_Decls : out List_Id;
Existing : out Boolean);
-- Add the declaration of the stub type, the access to stub type and the
-- object RPC receiver at the end of Decls. If these already exist,
-- then nothing is added in the tree but the right values are returned
-- anyhow and Existing is set to True.
+ function Get_And_Reset_RACW_Bodies (RACW_Type : Entity_Id) return List_Id;
+ -- Retrieve the Body_Decls list associated to RACW_Type in the stub
+ -- structure table, reset it to No_List, and return the previous value.
+
procedure Add_RACW_Asynchronous_Flag
(Declarations : List_Id;
RACW_Type : Entity_Id);
-- Exception_Message (E));
-- end R;
+ procedure Build_Actual_Object_Declaration
+ (Object : Entity_Id;
+ Etyp : Entity_Id;
+ Variable : Boolean;
+ Expr : Node_Id;
+ Decls : List_Id);
+ -- Build the declaration of an object with the given defining identifier,
+ -- initialized with Expr if provided, to serve as actual parameter in a
+ -- server stub. If Variable is true, the declared object will be a variable
+ -- (case of an out or in out formal), else it will be a constant. Object's
+ -- Ekind is set accordingly. The declaration, as well as any other
+ -- declarations it requires, are appended to Decls.
+
--------------------------------------------
-- Hooks for PCS-specific code generation --
--------------------------------------------
Stub_Type : Entity_Id;
Stub_Type_Access : Entity_Id;
RPC_Receiver_Decl : Node_Id;
- Declarations : List_Id);
+ Body_Decls : List_Id);
-- Add declaration for TSSs for a given RACW type. The declarations are
- -- added just after the declaration of the RACW type itself, while the
- -- bodies are inserted at the end of Decls. Runtime-specific ancillary
- -- subprogram for Add_RACW_Features.
+ -- added just after the declaration of the RACW type itself. If the RACW
+ -- appears in the main unit, Body_Decls is a list of declarations to which
+ -- the bodies are appended. Else Body_Decls is No_List.
+ -- PCS-specific ancillary subprogram for Add_RACW_Features.
procedure Specific_Add_RAST_Features
(Vis_Decl : Node_Id;
type RPC_Target (PCS_Kind : PCS_Names) is record
case PCS_Kind is
when Name_PolyORB_DSA =>
- Object : Node_Id;
+ 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
+ Partition : Entity_Id;
+ -- A variable containing the Partition_ID of the target partition
RPC_Receiver : Node_Id;
-- An expression whose value is the address of the target RPC
-- 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 Subtype_Mark if applicable
+ -- 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
procedure Specific_Build_Stub_Type
(RACW_Type : Entity_Id;
- Stub_Type : Entity_Id;
- Stub_Type_Decl : out Node_Id;
+ Stub_Type_Comps : out List_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
+ -- Build a components list for the stub type associated with an RACW type,
+ -- and build 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_Add_Receiving_Stubs_To_Declarations
(Pkg_Spec : Node_Id;
- Decls : List_Id);
+ Decls : List_Id;
+ Stmts : List_Id);
-- Add receiving stubs to the declarative part of an RCI unit
+ --------------------
+ -- GARLIC_Support --
+ --------------------
+
package GARLIC_Support is
-- Support for generating DSA code that uses the GARLIC PCS
- -- The subprograms below provide the GARLIC versions of
- -- the corresponding Specific_<subprogram> routine declared
- -- above.
+ -- 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);
+ Body_Decls : List_Id);
procedure Add_RAST_Features
(Vis_Decl : Node_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;
+ (RACW_Type : Entity_Id;
+ Stub_Type_Comps : out List_Id;
RPC_Receiver_Decl : out Node_Id);
function Build_Subprogram_Receiving_Stubs
procedure Add_Receiving_Stubs_To_Declarations
(Pkg_Spec : Node_Id;
- Decls : List_Id);
+ Decls : List_Id;
+ Stmts : List_Id);
procedure Build_RPC_Receiver_Body
(RPC_Receiver : Entity_Id;
end GARLIC_Support;
+ ---------------------
+ -- PolyORB_Support --
+ ---------------------
+
package PolyORB_Support is
-- Support for generating DSA code that uses the PolyORB PCS
- -- The subprograms below provide the PolyORB versions of
- -- the corresponding Specific_<subprogram> routine declared
- -- above.
+ -- The subprograms below provide the PolyORB 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);
+ Body_Decls : List_Id);
procedure Add_RAST_Features
(Vis_Decl : Node_Id;
procedure Build_Stub_Type
(RACW_Type : Entity_Id;
- Stub_Type : Entity_Id;
- Stub_Type_Decl : out Node_Id;
+ Stub_Type_Comps : out List_Id;
RPC_Receiver_Decl : out Node_Id);
function Build_Subprogram_Receiving_Stubs
procedure Add_Receiving_Stubs_To_Declarations
(Pkg_Spec : Node_Id;
- Decls : List_Id);
+ Decls : List_Id;
+ Stmts : List_Id);
procedure Build_RPC_Receiver_Body
(RPC_Receiver : Entity_Id;
-- their methods to be accessed as objects, for the implementation of
-- remote access-to-subprogram types).
+ -------------
+ -- Helpers --
+ -------------
+
package Helpers is
- -- Routines to build distribtion helper subprograms for user-defined
+ -- Routines to build distribution helper subprograms for user-defined
-- types. For implementation of the Distributed systems annex (DSA)
-- over the PolyORB generic middleware components, it is necessary to
-- generate several supporting subprograms for each application data
-- type used in inter-partition communication. These subprograms are:
- -- * a Typecode function returning a high-level description of the
- -- type's structure;
- -- * two conversion functions allowing conversion of values of the
- -- type from and to the generic data containers used by PolyORB.
- -- These generic containers are called 'Any' type values after
- -- the CORBA terminology, and hence the conversion subprograms
- -- are named To_Any and From_Any.
+
+ -- 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;
-- for entity E (a distributed object type or operation): one
-- containing the name of E, the second containing its repository id.
+ procedure Assign_Opaque_From_Any
+ (Loc : Source_Ptr;
+ Stms : List_Id;
+ Typ : Entity_Id;
+ N : Node_Id;
+ Target : Entity_Id);
+ -- For a Target object of type Typ, which has opaque representation
+ -- as a sequence of octets determined by stream attributes (which
+ -- includes all limited types), append code to Stmts performing the
+ -- equivalent of:
+ -- Target := Typ'From_Any (N)
+ --
+ -- or, if Target is Empty:
+ -- return Typ'From_Any (N)
+
end Helpers;
end PolyORB_Support;
+ -- The following PolyORB-specific subprograms are made visible to Exp_Attr:
+
+ function Build_From_Any_Call
+ (Typ : Entity_Id;
+ N : Node_Id;
+ Decls : List_Id) return Node_Id
+ renames PolyORB_Support.Helpers.Build_From_Any_Call;
+
+ function Build_To_Any_Call
+ (N : Node_Id;
+ Decls : List_Id) return Node_Id
+ renames PolyORB_Support.Helpers.Build_To_Any_Call;
+
+ function Build_TypeCode_Call
+ (Loc : Source_Ptr;
+ Typ : Entity_Id;
+ Decls : List_Id) return Node_Id
+ renames PolyORB_Support.Helpers.Build_TypeCode_Call;
+
------------------------------------
-- Local variables and structures --
------------------------------------
-- since this require separate mechanisms ('Input is a function while
-- 'Read is a procedure).
+ generic
+ with procedure Process_Subprogram_Declaration (Decl : Node_Id);
+ -- Generate calling or receiving stub for this subprogram declaration
+
+ procedure Build_Package_Stubs (Pkg_Spec : Node_Id);
+ -- Recursively visit the given RCI Package_Specification, calling
+ -- Process_Subprogram_Declaration for each remote subprogram.
+
+ -------------------------
+ -- Build_Package_Stubs --
+ -------------------------
+
+ procedure Build_Package_Stubs (Pkg_Spec : Node_Id) is
+ Decls : constant List_Id := Visible_Declarations (Pkg_Spec);
+ Decl : Node_Id;
+
+ procedure Visit_Nested_Pkg (Nested_Pkg_Decl : Node_Id);
+ -- Recurse for the given nested package declaration
+
+ -----------------------
+ -- Visit_Nested_Spec --
+ -----------------------
+
+ procedure Visit_Nested_Pkg (Nested_Pkg_Decl : Node_Id) is
+ Nested_Pkg_Spec : constant Node_Id := Specification (Nested_Pkg_Decl);
+ begin
+ Push_Scope (Scope_Of_Spec (Nested_Pkg_Spec));
+ Build_Package_Stubs (Nested_Pkg_Spec);
+ Pop_Scope;
+ end Visit_Nested_Pkg;
+
+ -- Start of processing for Build_Package_Stubs
+
+ begin
+ Decl := First (Decls);
+ while Present (Decl) loop
+ case Nkind (Decl) is
+ when N_Subprogram_Declaration =>
+
+ -- Note: we test Comes_From_Source on Spec, not Decl, because
+ -- in the case of a subprogram instance, only the specification
+ -- (not the declaration) is marked as coming from source.
+
+ if Comes_From_Source (Specification (Decl)) then
+ Process_Subprogram_Declaration (Decl);
+ end if;
+
+ when N_Package_Declaration =>
+
+ -- Case of a nested package or package instantiation coming
+ -- from source. Note that the anonymous wrapper package for
+ -- subprogram instances is not flagged Is_Generic_Instance at
+ -- this point, so there is a distinct circuit to handle them
+ -- (see case N_Subprogram_Instantiation below).
+
+ declare
+ Pkg_Ent : constant Entity_Id :=
+ Defining_Unit_Name (Specification (Decl));
+ begin
+ if Comes_From_Source (Decl)
+ or else
+ (Is_Generic_Instance (Pkg_Ent)
+ and then Comes_From_Source
+ (Get_Package_Instantiation_Node (Pkg_Ent)))
+ then
+ Visit_Nested_Pkg (Decl);
+ end if;
+ end;
+
+ when N_Subprogram_Instantiation =>
+
+ -- The subprogram declaration for an instance of a generic
+ -- subprogram is wrapped in a package that does not come from
+ -- source, so we need to explicitly traverse it here.
+
+ if Comes_From_Source (Decl) then
+ Visit_Nested_Pkg (Instance_Spec (Decl));
+ end if;
+
+ when others =>
+ null;
+ end case;
+ Next (Decl);
+ end loop;
+ end Build_Package_Stubs;
+
---------------------------------------
-- Add_Calling_Stubs_To_Declarations --
---------------------------------------
- procedure Add_Calling_Stubs_To_Declarations
- (Pkg_Spec : Node_Id;
- Decls : List_Id)
- is
+ procedure Add_Calling_Stubs_To_Declarations (Pkg_Spec : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (Pkg_Spec);
+
Current_Subprogram_Number : Int := First_RCI_Subprogram_Id;
-- Subprogram id 0 is reserved for calls received from
-- remote access-to-subprogram dereferences.
- Current_Declaration : Node_Id;
- Loc : constant Source_Ptr := Sloc (Pkg_Spec);
- RCI_Instantiation : Node_Id;
- Subp_Stubs : Node_Id;
- Subp_Str : String_Id;
+ RCI_Instantiation : Node_Id;
+
+ procedure Visit_Subprogram (Decl : Node_Id);
+ -- Generate calling stub for one remote subprogram
+
+ ----------------------
+ -- Visit_Subprogram --
+ ----------------------
+
+ procedure Visit_Subprogram (Decl : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (Decl);
+ Spec : constant Node_Id := Specification (Decl);
+ Subp_Stubs : Node_Id;
+
+ Subp_Str : String_Id;
+ pragma Warnings (Off, Subp_Str);
+
+ begin
+ Assign_Subprogram_Identifier
+ (Defining_Unit_Name (Spec), Current_Subprogram_Number, Subp_Str);
+
+ Subp_Stubs :=
+ Build_Subprogram_Calling_Stubs
+ (Vis_Decl => Decl,
+ Subp_Id =>
+ Build_Subprogram_Id (Loc, Defining_Unit_Name (Spec)),
+ Asynchronous =>
+ Nkind (Spec) = N_Procedure_Specification
+ and then Is_Asynchronous (Defining_Unit_Name (Spec)));
+
+ Append_To (List_Containing (Decl), Subp_Stubs);
+ Analyze (Subp_Stubs);
+
+ Current_Subprogram_Number := Current_Subprogram_Number + 1;
+ end Visit_Subprogram;
+
+ procedure Visit_Spec is new Build_Package_Stubs (Visit_Subprogram);
+
+ -- Start of processing for Add_Calling_Stubs_To_Declarations
begin
+ Push_Scope (Scope_Of_Spec (Pkg_Spec));
+
-- The first thing added is an instantiation of the generic package
- -- System.Partition_Interface.RCI_Locator with the name of this
- -- remote package. This will act as an interface with the name server
- -- to determine the Partition_ID and the RPC_Receiver for the
- -- receiver of this package.
+ -- 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);
+ Append_To (Visible_Declarations (Pkg_Spec), RCI_Instantiation);
Analyze (RCI_Instantiation);
- -- For each subprogram declaration visible in the spec, we do
- -- build a body. We also increment a counter to assign a different
- -- Subprogram_Id to each subprograms. The receiving stubs processing
- -- do use the same mechanism and will thus assign the same Id and
- -- do the correct dispatching.
+ -- For each subprogram declaration visible in the spec, we do build a
+ -- body. We also increment a counter to assign a different Subprogram_Id
+ -- to each subprogram. The receiving stubs processing uses the same
+ -- mechanism and will thus assign the same Id and do the correct
+ -- dispatching.
Overload_Counter_Table.Reset;
PolyORB_Support.Reserve_NamingContext_Methods;
- Current_Declaration := First (Visible_Declarations (Pkg_Spec));
+ Visit_Spec (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;
+ Pop_Scope;
end Add_Calling_Stubs_To_Declarations;
-----------------------------
(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.
+ -- 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 --
if Nkind (Parameter) = N_Defining_Identifier then
Get_Name_String (Chars (Parameter));
else
- Get_Name_String (Chars (Defining_Identifier
- (Parameter)));
+ 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);
+ if RACW_Ctrl or else Nkind (Parameter) = N_Defining_Identifier then
+
+ -- When the parameter passed to Add_Parameter_To_NVList is an
+ -- Extra_Constrained parameter, Parameter is an N_Defining_
+ -- Identifier, instead of a complete N_Parameter_Specification.
+ -- Thus, we explicitly set 'in' mode in this case.
+
+ Parameter_Mode := New_Occurrence_Of (RTE (RE_Mode_In), Loc);
+
else
- Parameter_Mode := Parameter_Passing_Mode (Loc,
- Parameter, Constrained);
+ Parameter_Mode :=
+ Parameter_Passing_Mode (Loc, Parameter, Constrained);
end if;
return
-- 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));
+ procedure Add_RACW_Features (RACW_Type : Entity_Id) is
+ Desig : constant Entity_Id := Etype (Designated_Type (RACW_Type));
+ Same_Scope : constant Boolean := Scope (Desig) = Scope (RACW_Type);
- Same_Scope : constant Boolean :=
- Scope (Desig) = Scope (RACW_Type);
+ Pkg_Spec : Node_Id;
+ Decls : List_Id;
+ Body_Decls : List_Id;
Stub_Type : Entity_Id;
Stub_Type_Access : Entity_Id;
RPC_Receiver_Decl : Node_Id;
- Existing : Boolean;
+
+ Existing : Boolean;
+ -- True when appropriate stubs have already been generated (this is the
+ -- case when another RACW with the same designated type has already been
+ -- encountered), in which case we reuse the previous stubs rather than
+ -- generating new ones.
begin
if not Expander_Active then
return;
end if;
+ -- Mark the current package declaration as containing an RACW, so that
+ -- the bodies for the calling stubs and the RACW stream subprograms
+ -- are attached to the tree when the corresponding body is encountered.
+
+ Set_Has_RACW (Current_Scope);
+
+ -- Look for place to declare the RACW stub type and RACW operations
+
+ Pkg_Spec := Empty;
+
if Same_Scope then
- -- 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.
+ -- Case of declaring the RACW in the same package as its designated
+ -- type: we know that the designated type is a private type, so we
+ -- use the private declarations list.
- Decls := Private_Declarations
- (Package_Specification_Of_Scope (Current_Scope));
+ Pkg_Spec := Package_Specification_Of_Scope (Current_Scope);
+
+ if Present (Private_Declarations (Pkg_Spec)) then
+ Decls := Private_Declarations (Pkg_Spec);
+ else
+ Decls := Visible_Declarations (Pkg_Spec);
+ end if;
+
+ else
+ -- Case of declaring the RACW in another package than its designated
+ -- type: use the private declarations list if present; otherwise
+ -- use the visible declarations.
+
+ Decls := List_Containing (Declaration_Node (RACW_Type));
- 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.
+ -- 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;
Stub_Type => Stub_Type,
Stub_Type_Access => Stub_Type_Access,
RPC_Receiver_Decl => RPC_Receiver_Decl,
+ Body_Decls => Body_Decls,
Existing => Existing);
+ -- If this RACW is not in the main unit, do not generate primitive or
+ -- TSS bodies.
+
+ if not Entity_Is_In_Main_Unit (RACW_Type) then
+ Body_Decls := No_List;
+ end if;
+
Add_RACW_Asynchronous_Flag
(Declarations => Decls,
RACW_Type => RACW_Type);
Stub_Type => Stub_Type,
Stub_Type_Access => Stub_Type_Access,
RPC_Receiver_Decl => RPC_Receiver_Decl,
- Declarations => Decls);
+ Body_Decls => Body_Decls);
- if not Same_Scope and then not Existing then
+ -- If we already have stubs for this designated type, nothing to do
- -- 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.
+ if Existing then
+ return;
+ end if;
+ if Is_Frozen (Desig) then
+ Validate_RACW_Primitives (RACW_Type);
Add_RACW_Primitive_Declarations_And_Bodies
(Designated_Type => Desig,
Insertion_Node => RPC_Receiver_Decl,
- Decls => Decls);
+ Body_Decls => Body_Decls);
else
+ -- Validate_RACW_Primitives requires the list of all primitives of
+ -- the designated type, so defer processing until Desig is frozen.
+ -- See Exp_Ch3.Freeze_Type.
+
Add_Access_Type_To_Process (E => Desig, A => RACW_Type);
end if;
end Add_RACW_Features;
procedure Add_RACW_Primitive_Declarations_And_Bodies
(Designated_Type : Entity_Id;
Insertion_Node : Node_Id;
- Decls : List_Id)
+ Body_Decls : List_Id)
is
+ Loc : constant Source_Ptr := Sloc (Insertion_Node);
-- Set Sloc of generated declaration copy of insertion node Sloc, so
-- the declarations are recognized as belonging to the current package.
- 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);
+ not Comes_From_Source (Stub_Elements.RACW_Type);
+ -- Case of the RACW generated to implement a remote access-to-
+ -- subprogram type.
+
+ Build_Bodies : constant Boolean :=
+ In_Extended_Main_Code_Unit (Stub_Elements.Stub_Type);
+ -- True when bodies must be prepared in Body_Decls. Bodies are generated
+ -- only when the main unit is the unit that contains the stub type.
Current_Insertion_Node : Node_Id := Insertion_Node;
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;
+ 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
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);
+ RPC_Receiver := Make_Temporary (Loc, 'P');
+
+ Specific_Build_RPC_Receiver_Body
+ (RPC_Receiver => RPC_Receiver,
+ Request => RPC_Receiver_Request,
+ Subp_Id => RPC_Receiver_Subp_Id,
+ Subp_Index => RPC_Receiver_Subp_Index,
+ Stmts => RPC_Receiver_Statements,
+ Decl => RPC_Receiver_Decl);
if Get_PCS_Name = Name_PolyORB_DSA then
-- For the case of PolyORB, we need to map a textual operation
- -- name into a primitive index. Currently we do so using a
- -- simple sequence of string comparisons.
+ -- 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.
+ -- receiver for this type. Note that we use Direct_Primitive_Operations,
+ -- not Primitive_Operations, because we really want just the primitives
+ -- of the tagged type itself, and in the case of a tagged synchronized
+ -- type we do not want to get the primitives of the corresponding
+ -- record type).
- if Present (Primitive_Operations (Designated_Type)) then
+ if Present (Direct_Primitive_Operations (Designated_Type)) then
Overload_Counter_Table.Reset;
Current_Primitive_Elmt :=
- First_Elmt (Primitive_Operations (Designated_Type));
+ First_Elmt (Direct_Primitive_Operations (Designated_Type));
while Current_Primitive_Elmt /= No_Elmt loop
Current_Primitive := Node (Current_Primitive_Elmt);
- -- Copy the primitive of all the parents, except predefined
- -- ones that are not remotely dispatching.
+ -- Copy the primitive of all the parents, except predefined ones
+ -- that are not remotely dispatching. Also omit hidden primitives
+ -- (occurs in the case of primitives of interface progenitors
+ -- other than immediate ancestors of the Designated_Type).
if Chars (Current_Primitive) /= Name_uSize
and then Chars (Current_Primitive) /= Name_uAlignment
- and then not Is_TSS (Current_Primitive, TSS_Deep_Finalize)
+ and then not
+ (Is_TSS (Current_Primitive, TSS_Deep_Finalize) or else
+ Is_TSS (Current_Primitive, TSS_Stream_Input) or else
+ Is_TSS (Current_Primitive, TSS_Stream_Output) or else
+ Is_TSS (Current_Primitive, TSS_Stream_Read) or else
+ Is_TSS (Current_Primitive, TSS_Stream_Write)
+ or else
+ Is_Predefined_Interface_Primitive (Current_Primitive))
+ and then not Is_Hidden (Current_Primitive)
then
- -- The first thing to do is build an up-to-date copy of
- -- the spec with all the formals referencing Designated_Type
+ -- The first thing to do is build an up-to-date copy of the
+ -- spec with all the formals referencing Controlling_Type
-- transformed into formals referencing Stub_Type. Since this
-- primitive may have been inherited, go back the alias chain
-- until the real primitive has been found.
- Current_Primitive_Alias := 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_Alias := Ultimate_Alias (Current_Primitive);
+
+ -- Copy the spec from the original declaration for the purpose
+ -- of declaring an overriding subprogram: we need to replace
+ -- the type of each controlling formal with Stub_Type. The
+ -- primitive may have been declared for Controlling_Type or
+ -- inherited from some ancestor type for which we do not have
+ -- an easily determined Entity_Id. We have no systematic way
+ -- of knowing which type to substitute Stub_Type for. Instead,
+ -- Copy_Specification relies on the flag Is_Controlling_Formal
+ -- to determine which formals to change.
Current_Primitive_Spec :=
Copy_Specification (Loc,
Spec => Parent (Current_Primitive_Alias),
- Object_Type => Designated_Type,
- Stub_Type => Stub_Elements.Stub_Type);
+ Ctrl_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);
+ Insert_After_And_Analyze (Current_Insertion_Node,
+ Current_Primitive_Decl);
Current_Insertion_Node := Current_Primitive_Decl;
Possibly_Asynchronous :=
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.
+ if Build_Bodies then
+ Current_Primitive_Body :=
+ Build_Subprogram_Calling_Stubs
+ (Vis_Decl => Current_Primitive_Decl,
+ Subp_Id =>
+ Build_Subprogram_Id (Loc,
+ Defining_Unit_Name (Current_Primitive_Spec)),
+ Asynchronous => Possibly_Asynchronous,
+ Dynamically_Asynchronous => Possibly_Asynchronous,
+ Stub_Type => Stub_Elements.Stub_Type,
+ RACW_Type => Stub_Elements.RACW_Type);
+ Append_To (Body_Decls, Current_Primitive_Body);
+
+ -- Analyzing the body here would cause the Stub type to
+ -- be frozen, thus preventing subsequent primitive
+ -- declarations. For this reason, it will be analyzed
+ -- later in the regular flow (and in the context of the
+ -- appropriate unit body, see Append_RACW_Bodies).
+
+ end if;
-- Build the receiver stubs
- if not Is_RAS then
+ if Build_Bodies and then not Is_RAS then
Current_Receiver_Body :=
Specific_Build_Subprogram_Receiving_Stubs
(Vis_Decl => Current_Primitive_Decl,
RACW_Type => Stub_Elements.RACW_Type,
Parent_Primitive => Current_Primitive);
- Current_Receiver := Defining_Unit_Name (
- Specification (Current_Receiver_Body));
+ Current_Receiver :=
+ Defining_Unit_Name (Specification (Current_Receiver_Body));
- Append_To (Decls, Current_Receiver_Body);
+ Append_To (Body_Decls, Current_Receiver_Body);
-- Add a case alternative to the receiver
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)))));
+ Intval => Current_Primitive_Number)))));
end if;
Append_To (RPC_Receiver_Case_Alternatives,
-- Build the case statement and the heart of the subprogram
- if not Is_RAS then
+ if Build_Bodies and then not Is_RAS then
if Get_PCS_Name = Name_PolyORB_DSA
and then Present (First (RPC_Receiver_Elsif_Parts))
then
New_Occurrence_Of (RPC_Receiver_Subp_Index, Loc),
Alternatives => RPC_Receiver_Case_Alternatives));
- Append_To (Decls, RPC_Receiver_Decl);
+ Append_To (Body_Decls, RPC_Receiver_Decl);
Specific_Add_Obj_RPC_Receiver_Completion (Loc,
- Decls, RPC_Receiver, Stub_Elements);
- end if;
+ Body_Decls, RPC_Receiver, Stub_Elements);
- -- 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.
+ -- Do not analyze RPC receiver body at this stage since it references
+ -- subprograms that have not been analyzed yet. It will be analyzed in
+ -- the regular flow (see Append_RACW_Bodies).
+ end if;
end Add_RACW_Primitive_Declarations_And_Bodies;
-----------------------------
procedure Add_RAS_Dereference_TSS (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
- Type_Def : constant Node_Id := Type_Definition (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;
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'));
+ RAS_Parameter : constant Entity_Id := Make_Temporary (Loc, 'P');
Is_Function : constant Boolean :=
Nkind (Type_Def) = N_Access_Function_Definition;
Is_Degenerate : Boolean;
- -- Set to True if the subprogram_specification for this RAS has
- -- an anonymous access parameter (see Process_Remote_AST_Declaration).
+ -- 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;
-- Start of processing for Add_RAS_Dereference_TSS
begin
- -- The Dereference TSS for a remote access-to-subprogram type
- -- has the form:
+ -- The Dereference TSS for a remote access-to-subprogram type has the
+ -- form:
-- [function|procedure] ras_typeRD (RAS_Value, <RAS_Parameters>)
-- [return <>]
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
+ 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 =>
-- 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.
+ -- 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));
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.
+ -- 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);
+ RACW_Primitive_Name :=
+ Make_Selected_Component (Loc,
+ Prefix => Scope (RACW_Type),
+ Selector_Name => Name_uCall);
end if;
if Is_Function then
Append_To (Stmts,
- Make_Return_Statement (Loc,
+ Make_Simple_Return_Statement (Loc,
Expression =>
Make_Function_Call (Loc,
- Name =>
- RACW_Primitive_Name,
- Parameter_Associations => Param_Assoc)));
+ Name => RACW_Primitive_Name,
+ Parameter_Associations => Param_Assoc)));
else
Append_To (Stmts,
Make_Procedure_Call_Statement (Loc,
- Name =>
- RACW_Primitive_Name,
+ Name => RACW_Primitive_Name,
Parameter_Associations => Param_Assoc));
end if;
Make_Function_Specification (Loc,
Defining_Unit_Name => Proc,
Parameter_Specifications => Param_Specs,
- Subtype_Mark =>
+ Result_Definition =>
New_Occurrence_Of (
- Entity (Subtype_Mark (Spec)), Loc));
+ Entity (Result_Definition (Spec)), Loc));
Set_Ekind (Proc, E_Function);
Set_Etype (Proc,
- New_Occurrence_Of (Entity (Subtype_Mark (Spec)), Loc));
+ New_Occurrence_Of (Entity (Result_Definition (Spec)), Loc));
else
Proc_Spec :=
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));
+ 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'));
+ New_External_Name
+ (Related_Id => Chars (Subp_Name),
+ Suffix => 'P'));
Proxy_Type_Full_View : constant Entity_Id :=
Make_Defining_Identifier (Loc,
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)));
+ Defining_Identifier => Proxy_Object_Addr,
+ Constant_Present => True,
+ Object_Definition => New_Occurrence_Of (RTE (RE_Address), Loc)));
-- private
Append_To (Pvt_Decls,
Make_Full_Type_Declaration (Loc,
- Defining_Identifier =>
- Proxy_Type_Full_View,
+ 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.
+ -- Trick semantic analysis into swapping the public and full view when
+ -- freezing the public view.
Set_Comes_From_Source (Proxy_Type_Full_View, True);
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);
+ Name => New_Occurrence_Of (Subp_Name, Loc),
+ Parameter_Associations => Actuals);
else
Perform_Call :=
- Make_Return_Statement (Loc,
+ Make_Simple_Return_Statement (Loc,
Expression =>
- Make_Function_Call (Loc,
- Name =>
- New_Occurrence_Of (Subp_Name, Loc),
- Parameter_Associations =>
- Actuals));
+ Make_Function_Call (Loc,
+ Name => New_Occurrence_Of (Subp_Name, Loc),
+ Parameter_Associations => Actuals));
end if;
Formal := First (Parameter_Specifications (Subp_Decl_Spec));
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)));
+ 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),
+ 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)));
+ Attribute_Name => Name_Address)));
Append_To (Decls,
Make_Package_Declaration (Loc,
Append_To (Decls,
Make_Package_Body (Loc,
Defining_Unit_Name =>
- Make_Defining_Identifier (Loc,
- Chars (Pkg_Name)),
+ Make_Defining_Identifier (Loc, Chars (Pkg_Name)),
Declarations => New_List (
Make_Subprogram_Body (Loc,
- Specification =>
- Subp_Body_Spec,
+ Specification => Subp_Body_Spec,
Declarations => New_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Stub_Type : out Entity_Id;
Stub_Type_Access : out Entity_Id;
RPC_Receiver_Decl : out Node_Id;
+ Body_Decls : out List_Id;
Existing : out Boolean)
is
Loc : constant Source_Ptr := Sloc (RACW_Type);
- Stub_Elements : constant Stub_Structure :=
- Stubs_Table.Get (Designated_Type);
+ Stub_Elements : constant Stub_Structure :=
+ Stubs_Table.Get (Designated_Type);
+ Stub_Type_Comps : List_Id;
Stub_Type_Decl : Node_Id;
Stub_Type_Access_Decl : Node_Id;
Stub_Type := Stub_Elements.Stub_Type;
Stub_Type_Access := Stub_Elements.Stub_Type_Access;
RPC_Receiver_Decl := Stub_Elements.RPC_Receiver_Decl;
+ Body_Decls := Stub_Elements.Body_Decls;
Existing := True;
return;
end if;
- Existing := False;
- Stub_Type :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
+ Existing := False;
+ Stub_Type := Make_Temporary (Loc, 'S');
+ Set_Ekind (Stub_Type, E_Record_Type);
+ Set_Is_RACW_Stub_Type (Stub_Type);
Stub_Type_Access :=
Make_Defining_Identifier (Loc,
- New_External_Name (
- Related_Id => Chars (Stub_Type),
- Suffix => 'A'));
+ Chars => New_External_Name
+ (Related_Id => Chars (Stub_Type), Suffix => 'A'));
+
+ Specific_Build_Stub_Type (RACW_Type, Stub_Type_Comps, RPC_Receiver_Decl);
- Specific_Build_Stub_Type (
- RACW_Type, Stub_Type,
- Stub_Type_Decl, RPC_Receiver_Decl);
+ 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 => Stub_Type_Comps)));
+
+ -- Does the stub type need to explicitly implement interfaces from the
+ -- designated type???
+
+ -- In particular are there issues in the case where the designated type
+ -- is a synchronized interface???
Stub_Type_Access_Decl :=
Make_Full_Type_Declaration (Loc,
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.
+ -- We can't directly derive the stub type from the designated type,
+ -- because we don't want any components or discriminants from the real
+ -- type, so instead we manually fake a derivation to get an appropriate
+ -- dispatch table.
Derive_Subprograms (Parent_Type => Designated_Type,
Derived_Type => Stub_Type);
RPC_Receiver_Decl := Last (Decls);
end if;
+ Body_Decls := New_List;
+
Stubs_Table.Set (Designated_Type,
(Stub_Type => Stub_Type,
Stub_Type_Access => Stub_Type_Access,
RPC_Receiver_Decl => RPC_Receiver_Decl,
+ Body_Decls => Body_Decls,
RACW_Type => RACW_Type));
end Add_Stub_Type;
+ ------------------------
+ -- Append_RACW_Bodies --
+ ------------------------
+
+ procedure Append_RACW_Bodies (Decls : List_Id; Spec_Id : Entity_Id) is
+ E : Entity_Id;
+
+ begin
+ E := First_Entity (Spec_Id);
+ while Present (E) loop
+ if Is_Remote_Access_To_Class_Wide_Type (E) then
+ Append_List_To (Decls, Get_And_Reset_RACW_Bodies (E));
+ end if;
+
+ Next_Entity (E);
+ end loop;
+ end Append_RACW_Bodies;
+
----------------------------------
-- Assign_Subprogram_Identifier --
----------------------------------
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.
+ -- 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) := "__";
end if;
Id := String_From_Name_Buffer;
- Subprogram_Identifier_Table.Set (Def,
- Subprogram_Identifiers'(Str_Identifier => Id, Int_Identifier => Spn));
+ Subprogram_Identifier_Table.Set
+ (Def,
+ Subprogram_Identifiers'(Str_Identifier => Id, Int_Identifier => Spn));
end Assign_Subprogram_Identifier;
+ -------------------------------------
+ -- Build_Actual_Object_Declaration --
+ -------------------------------------
+
+ procedure Build_Actual_Object_Declaration
+ (Object : Entity_Id;
+ Etyp : Entity_Id;
+ Variable : Boolean;
+ Expr : Node_Id;
+ Decls : List_Id)
+ is
+ Loc : constant Source_Ptr := Sloc (Object);
+
+ begin
+ -- Declare a temporary object for the actual, possibly initialized with
+ -- a 'Input/From_Any call.
+
+ -- Complication arises in the case of limited types, for which such a
+ -- declaration is illegal in Ada 95. In that case, we first generate a
+ -- renaming declaration of the 'Input call, and then if needed we
+ -- generate an overlaid non-constant view.
+
+ if Ada_Version <= Ada_95
+ and then Is_Limited_Type (Etyp)
+ and then Present (Expr)
+ then
+
+ -- Object : Etyp renames <func-call>
+
+ Append_To (Decls,
+ Make_Object_Renaming_Declaration (Loc,
+ Defining_Identifier => Object,
+ Subtype_Mark => New_Occurrence_Of (Etyp, Loc),
+ Name => Expr));
+
+ if Variable then
+
+ -- The name defined by the renaming declaration denotes a
+ -- constant view; create a non-constant object at the same address
+ -- to be used as the actual.
+
+ declare
+ Constant_Object : constant Entity_Id :=
+ Make_Temporary (Loc, 'P');
+
+ begin
+ Set_Defining_Identifier
+ (Last (Decls), Constant_Object);
+
+ -- We have an unconstrained Etyp: build the actual constrained
+ -- subtype for the value we just read from the stream.
+
+ -- subtype S is <actual subtype of Constant_Object>;
+
+ Append_To (Decls,
+ Build_Actual_Subtype (Etyp,
+ New_Occurrence_Of (Constant_Object, Loc)));
+
+ -- Object : S;
+
+ Append_To (Decls,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Object,
+ Object_Definition =>
+ New_Occurrence_Of
+ (Defining_Identifier (Last (Decls)), Loc)));
+ Set_Ekind (Object, E_Variable);
+
+ -- Suppress default initialization:
+ -- pragma Import (Ada, Object);
+
+ Append_To (Decls,
+ Make_Pragma (Loc,
+ Chars => Name_Import,
+ Pragma_Argument_Associations => New_List (
+ Make_Pragma_Argument_Association (Loc,
+ Chars => Name_Convention,
+ Expression => Make_Identifier (Loc, Name_Ada)),
+ Make_Pragma_Argument_Association (Loc,
+ Chars => Name_Entity,
+ Expression => New_Occurrence_Of (Object, Loc)))));
+
+ -- for Object'Address use Constant_Object'Address;
+
+ Append_To (Decls,
+ Make_Attribute_Definition_Clause (Loc,
+ Name => New_Occurrence_Of (Object, Loc),
+ Chars => Name_Address,
+ Expression =>
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Constant_Object, Loc),
+ Attribute_Name => Name_Address)));
+ end;
+ end if;
+
+ else
+ -- General case of a regular object declaration. Object is flagged
+ -- constant unless it has mode out or in out, to allow the backend
+ -- to optimize where possible.
+
+ -- Object : [constant] Etyp [:= <expr>];
+
+ Append_To (Decls,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Object,
+ Constant_Present => Present (Expr) and then not Variable,
+ Object_Definition => New_Occurrence_Of (Etyp, Loc),
+ Expression => Expr));
+
+ if Constant_Present (Last (Decls)) then
+ Set_Ekind (Object, E_Constant);
+ else
+ Set_Ekind (Object, E_Variable);
+ end if;
+ end if;
+ end Build_Actual_Object_Declaration;
+
------------------------------
-- Build_Get_Unique_RP_Call --
------------------------------
Make_Assignment_Statement (Loc,
Name =>
Make_Selected_Component (Loc,
- Prefix =>
- New_Occurrence_Of (Pointer, 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)));
+ 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
Constrained_List : List_Id;
Unconstrained_List : List_Id;
Current_Parameter : Node_Id;
+ Ptyp : Node_Id;
First_Parameter : Node_Id;
For_RAS : Boolean := False;
begin
- if not Present (Parameter_Specifications (Spec)) then
+ if No (Parameter_Specifications (Spec)) then
return New_List;
end if;
For_RAS := True;
end if;
- -- Loop through the parameters and add them to the right list
+ -- Loop through the parameters and add them to the right list. Note that
+ -- we treat a parameter of a null-excluding access type as unconstrained
+ -- because we can't declare an object of such a type with default
+ -- initialization.
Current_Parameter := First_Parameter;
while Present (Current_Parameter) loop
- 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))))
+ Ptyp := Parameter_Type (Current_Parameter);
+
+ if (Nkind (Ptyp) = N_Access_Definition
+ or else not Transmit_As_Unconstrained (Etype (Ptyp)))
and then not (For_RAS and then Current_Parameter = First_Parameter)
then
Append_To (Constrained_List, New_Copy (Current_Parameter));
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc),
- Attribute_Name =>
- Name_Version)));
+ Attribute_Name => Name_Version)));
Append_To (L, Reg);
Analyze (Reg);
end Build_Passive_Partition_Stub;
New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc))))));
end Build_Remote_Subprogram_Proxy_Type;
+ --------------------
+ -- Build_Stub_Tag --
+ --------------------
+
+ function Build_Stub_Tag
+ (Loc : Source_Ptr;
+ RACW_Type : Entity_Id) return Node_Id
+ is
+ Stub_Type : constant Entity_Id := Corresponding_Stub_Type (RACW_Type);
+ begin
+ return
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Stub_Type, Loc),
+ Attribute_Name => Name_Tag);
+ end Build_Stub_Tag;
+
------------------------------------
-- Build_Subprogram_Calling_Stubs --
------------------------------------
-- Start of processing for Build_Subprogram_Calling_Stubs
begin
- Subp_Spec := Copy_Specification (Loc,
- Spec => Specification (Vis_Decl),
- New_Name => New_Name);
+ Subp_Spec :=
+ Copy_Specification (Loc,
+ Spec => Specification (Vis_Decl),
+ New_Name => New_Name);
if Locator = Empty then
RCI_Locator := RCI_Cache;
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;
+ if Get_Subprogram_Ids (E).Str_Identifier = No_String then
+ declare
+ Current_Declaration : Node_Id;
+ Current_Subp : Entity_Id;
+ Current_Subp_Str : String_Id;
+ Current_Subp_Number : Int := First_RCI_Subprogram_Id;
- ------------------------
- -- Copy_Specification --
- ------------------------
+ pragma Warnings (Off, Current_Subp_Str);
- 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
+ begin
+ -- Build_Subprogram_Id is called outside of the context of
+ -- generating calling or receiving stubs. Hence we are processing
+ -- an 'Access attribute_reference for an RCI subprogram, for the
+ -- purpose of obtaining a RAS value.
+
+ pragma Assert
+ (Is_Remote_Call_Interface (Scope (E))
+ and then
+ (Nkind (Parent (E)) = N_Procedure_Specification
+ or else
+ Nkind (Parent (E)) = N_Function_Specification));
+
+ Current_Declaration :=
+ First (Visible_Declarations
+ (Package_Specification_Of_Scope (Scope (E))));
+ while Present (Current_Declaration) loop
+ if Nkind (Current_Declaration) = N_Subprogram_Declaration
+ and then Comes_From_Source (Current_Declaration)
+ then
+ Current_Subp := Defining_Unit_Name (Specification (
+ Current_Declaration));
+
+ Assign_Subprogram_Identifier
+ (Current_Subp, Current_Subp_Number, Current_Subp_Str);
+
+ Current_Subp_Number := Current_Subp_Number + 1;
+ end if;
+
+ Next (Current_Declaration);
+ end loop;
+ end;
+ end if;
+
+ case Get_PCS_Name is
+ when Name_PolyORB_DSA =>
+ return Make_String_Literal (Loc, Get_Subprogram_Id (E));
+ when others =>
+ return Make_Integer_Literal (Loc, Get_Subprogram_Id (E));
+ end case;
+ end Build_Subprogram_Id;
+
+ ------------------------
+ -- Copy_Specification --
+ ------------------------
+
+ function Copy_Specification
+ (Loc : Source_Ptr;
+ Spec : Node_Id;
+ Ctrl_Type : Entity_Id := Empty;
+ New_Name : Name_Id := No_Name) return Node_Id
+ is
Parameters : List_Id := No_List;
Current_Parameter : Node_Id;
Current_Identifier : Entity_Id;
Current_Type : Node_Id;
- Current_Etype : Entity_Id;
Name_For_New_Spec : Name_Id;
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));
+ if Present (Ctrl_Type) then
+ pragma Assert (Is_Controlling_Formal (Current_Identifier));
Current_Type :=
Make_Access_Definition (Loc,
- Subtype_Mark => New_Occurrence_Of (Stub_Type, Loc));
+ Subtype_Mark => New_Occurrence_Of (Ctrl_Type, Loc),
+ Null_Exclusion_Present =>
+ Null_Exclusion_Present (Current_Type));
+
else
Current_Type :=
Make_Access_Definition (Loc,
Subtype_Mark =>
- New_Occurrence_Of (Current_Etype, Loc));
+ New_Copy_Tree (Subtype_Mark (Current_Type)),
+ 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
+ if Present (Ctrl_Type)
+ and then Is_Controlling_Formal (Current_Identifier)
then
- Current_Type := New_Occurrence_Of (Stub_Type, Loc);
+ Current_Type := New_Occurrence_Of (Ctrl_Type, Loc);
else
- Current_Type := New_Occurrence_Of (Current_Etype, Loc);
+ Current_Type := New_Copy_Tree (Current_Type);
end if;
end if;
Make_Defining_Identifier (Loc,
Chars => Name_For_New_Spec),
Parameter_Specifications => Parameters,
- Subtype_Mark =>
- New_Occurrence_Of (Entity (Subtype_Mark (Spec)), Loc));
+ Result_Definition =>
+ New_Occurrence_Of (Entity (Result_Definition (Spec)), Loc));
when N_Procedure_Specification | N_Access_Procedure_Definition =>
return
end case;
end Copy_Specification;
+ -----------------------------
+ -- Corresponding_Stub_Type --
+ -----------------------------
+
+ function Corresponding_Stub_Type (RACW_Type : Entity_Id) return Entity_Id is
+ Desig : constant Entity_Id :=
+ Etype (Designated_Type (RACW_Type));
+ Stub_Elements : constant Stub_Structure := Stubs_Table.Get (Desig);
+ begin
+ return Stub_Elements.Stub_Type;
+ end Corresponding_Stub_Type;
+
---------------------------
-- Could_Be_Asynchronous --
---------------------------
Append_To (Stmts,
Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of (RTE (RE_NVList_Create), Loc),
+ Name => New_Occurrence_Of (RTE (RE_NVList_Create), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (NVList, Loc))));
end Declare_Create_NVList;
---------------------------------------------
procedure Expand_All_Calls_Remote_Subprogram_Call (N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
Called_Subprogram : constant Entity_Id := Entity (Name (N));
RCI_Package : constant Entity_Id := Scope (Called_Subprogram);
- Loc : constant Source_Ptr := Sloc (N);
- RCI_Locator : Node_Id;
- RCI_Cache : Entity_Id;
+ RCI_Locator_Decl : Node_Id;
+ RCI_Locator : Entity_Id;
Calling_Stubs : Node_Id;
E_Calling_Stubs : Entity_Id;
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)));
+ RCI_Locator := RCI_Locator_Table.Get (RCI_Package);
- else
- New_Scope (Scop);
- end if;
+ -- The RCI_Locator package and calling stub are is inserted at the
+ -- top level in the current unit, and must appear in the proper scope
+ -- so that it is not prematurely removed by the GCC back end.
- Analyze (RCI_Locator);
- Pop_Scope;
- end;
+ declare
+ Scop : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
+ begin
+ if Ekind (Scop) = E_Package_Body then
+ Push_Scope (Spec_Entity (Scop));
+ elsif Ekind (Scop) = E_Subprogram_Body then
+ Push_Scope
+ (Corresponding_Spec (Unit_Declaration_Node (Scop)));
+ else
+ Push_Scope (Scop);
+ end if;
+ end;
- RCI_Cache := Defining_Unit_Name (RCI_Locator);
+ if RCI_Locator = Empty then
+ RCI_Locator_Decl :=
+ RCI_Package_Locator
+ (Loc, Specification (Unit_Declaration_Node (RCI_Package)));
+ Prepend_To (Current_Sem_Unit_Declarations, RCI_Locator_Decl);
+ Analyze (RCI_Locator_Decl);
+ RCI_Locator := Defining_Unit_Name (RCI_Locator_Decl);
else
- RCI_Locator := Parent (RCI_Cache);
+ RCI_Locator_Decl := Parent (RCI_Locator);
end if;
Calling_Stubs := Build_Subprogram_Calling_Stubs
Asynchronous => Nkind (N) = N_Procedure_Call_Statement
and then
Is_Asynchronous (Called_Subprogram),
- Locator => RCI_Cache,
+ Locator => RCI_Locator,
New_Name => New_Internal_Name ('S'));
- Insert_After (RCI_Locator, Calling_Stubs);
+ Insert_After (RCI_Locator_Decl, Calling_Stubs);
Analyze (Calling_Stubs);
+ Pop_Scope;
+
E_Calling_Stubs := Defining_Unit_Name (Specification (Calling_Stubs));
end if;
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;
+ Add_Calling_Stubs_To_Declarations (Spec);
end Expand_Calling_Stubs_Bodies;
-----------------------------------
-----------------------------------
procedure Expand_Receiving_Stubs_Bodies (Unit_Node : Node_Id) is
- Spec : Node_Id;
- Decls : List_Id;
- Temp : List_Id;
+ Spec : Node_Id;
+ Decls : List_Id;
+ Stubs_Decls : List_Id;
+ Stubs_Stmts : List_Id;
begin
if Nkind (Unit_Node) = N_Package_Declaration then
Decls := Visible_Declarations (Spec);
end if;
- New_Scope (Scope_Of_Spec (Spec));
- Specific_Add_Receiving_Stubs_To_Declarations (Spec, Decls);
+ Push_Scope (Scope_Of_Spec (Spec));
+ Specific_Add_Receiving_Stubs_To_Declarations (Spec, Decls, Decls);
else
- Spec :=
+ 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);
+
+ Push_Scope (Scope_Of_Spec (Unit_Node));
+ Stubs_Decls := New_List;
+ Stubs_Stmts := New_List;
+ Specific_Add_Receiving_Stubs_To_Declarations
+ (Spec, Stubs_Decls, Stubs_Stmts);
+
+ Insert_List_Before (First (Decls), Stubs_Decls);
+
+ declare
+ HSS_Stmts : constant List_Id :=
+ Statements (Handled_Statement_Sequence (Unit_Node));
+
+ First_HSS_Stmt : constant Node_Id := First (HSS_Stmts);
+
+ begin
+ if No (First_HSS_Stmt) then
+ Append_List_To (HSS_Stmts, Stubs_Stmts);
+ else
+ Insert_List_Before (First_HSS_Stmt, Stubs_Stmts);
+ end if;
+ end;
end if;
Pop_Scope;
(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.
+ Body_Decls : List_Id);
+ -- Add Read attribute for the RACW type. The declaration and attribute
+ -- definition clauses are inserted right after the declaration of
+ -- RACW_Type. If Body_Decls is not No_List, the subprogram body is
+ -- appended to it (case where the RACW declaration is in the main unit).
procedure Add_RACW_Write_Attribute
(RACW_Type : Entity_Id;
Stub_Type : Entity_Id;
Stub_Type_Access : Entity_Id;
RPC_Receiver : Node_Id;
- Declarations : List_Id);
- -- Same thing for the Write attribute
+ Body_Decls : List_Id);
+ -- Same as above for the Write attribute
function Stream_Parameter return Node_Id;
function Result return Node_Id;
function Object return Node_Id renames Result;
- -- Functions to create occurrences of the formal parameter names of
- -- the 'Read and 'Write attributes.
+ -- 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).
+ -- 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
(Loc : Source_Ptr;
Decls : List_Id;
RPC_Receiver : Entity_Id;
- Stub_Elements : Stub_Structure) is
+ 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.
+ -- 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,
Stub_Type : Entity_Id;
Stub_Type_Access : Entity_Id;
RPC_Receiver_Decl : Node_Id;
- Declarations : List_Id)
+ Body_Decls : List_Id)
is
RPC_Receiver : Node_Id;
Is_RAS : constant Boolean := not Comes_From_Source (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.
+ -- 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 =>
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);
+ Add_RACW_Write_Attribute
+ (RACW_Type,
+ Stub_Type,
+ Stub_Type_Access,
+ RPC_Receiver,
+ Body_Decls);
+
+ Add_RACW_Read_Attribute
+ (RACW_Type,
+ Stub_Type,
+ Stub_Type_Access,
+ Body_Decls);
end Add_RACW_Features;
-----------------------------
(RACW_Type : Entity_Id;
Stub_Type : Entity_Id;
Stub_Type_Access : Entity_Id;
- Declarations : List_Id)
+ Body_Decls : List_Id)
is
Proc_Decl : Node_Id;
Attr_Decl : Node_Id;
Body_Node : Node_Id;
+ Statements : constant List_Id := New_List;
Decls : List_Id;
- 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'));
+ Pnam : constant Entity_Id := Make_Temporary (Loc, 'R');
Asynchronous_Flag : constant Entity_Id :=
Asynchronous_Flags_Table.Get (RACW_Type);
pragma Assert (Present (Asynchronous_Flag));
+ -- Prepare local identifiers
+
+ Source_Partition : Entity_Id;
+ Source_Receiver : Entity_Id;
+ Source_Address : Entity_Id;
+ Local_Stub : Entity_Id;
+ Stubbed_Result : Entity_Id;
+
-- Start of processing for Add_RACW_Read_Attribute
begin
+ Build_Stream_Procedure (Loc,
+ RACW_Type, Body_Node, Pnam, Statements, Outp => True);
+ Proc_Decl := Make_Subprogram_Declaration (Loc,
+ Copy_Specification (Loc, Specification (Body_Node)));
+
+ Attr_Decl :=
+ Make_Attribute_Definition_Clause (Loc,
+ Name => New_Occurrence_Of (RACW_Type, Loc),
+ Chars => Name_Read,
+ Expression =>
+ New_Occurrence_Of (
+ Defining_Unit_Name (Specification (Proc_Decl)), Loc));
+
+ Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
+ Insert_After (Proc_Decl, Attr_Decl);
+
+ if No (Body_Decls) then
+
+ -- Case of processing an RACW type from another unit than the
+ -- main one: do not generate a body.
+
+ return;
+ end if;
+
+ -- Prepare local identifiers
+
+ Source_Partition := Make_Temporary (Loc, 'P');
+ Source_Receiver := Make_Temporary (Loc, 'S');
+ Source_Address := Make_Temporary (Loc, 'P');
+ Local_Stub := Make_Temporary (Loc, 'L');
+ Stubbed_Result := Make_Temporary (Loc, 'S');
+
-- Generate object declarations
Decls := New_List (
-- Read the source Partition_ID and RPC_Receiver from incoming stream
- Statements := New_List (
+ Append_List_To (Statements, New_List (
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
Name_Read,
Expressions => New_List (
Stream_Parameter,
- New_Occurrence_Of (Source_Address, Loc))));
+ 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
+ -- If the Address is Null_Address, then return a null object, unless
+ -- RACW_Type is null-excluding, in which case unconditionally raise
+ -- CONSTRAINT_ERROR instead.
- 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))));
+ declare
+ Zero_Statements : List_Id;
+ -- Statements executed when a zero value is received
+
+ begin
+ if Can_Never_Be_Null (RACW_Type) then
+ Zero_Statements := New_List (
+ Make_Raise_Constraint_Error (Loc,
+ Reason => CE_Null_Not_Allowed));
+ else
+ Zero_Statements := New_List (
+ Make_Assignment_Statement (Loc,
+ Name => Result,
+ Expression => Make_Null (Loc)),
+ Make_Simple_Return_Statement (Loc));
+ end if;
+
+ Append_To (Statements,
+ Make_Implicit_If_Statement (RACW_Type,
+ Condition =>
+ Make_Op_Eq (Loc,
+ Left_Opnd => New_Occurrence_Of (Source_Address, Loc),
+ Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
+ Then_Statements => Zero_Statements));
+ end;
-- If the RACW denotes an object created on the current partition,
-- Local_Statements will be executed. The real object will be used.
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.
+ -- ??? 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,
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);
+ Append_To (Body_Decls, Body_Node);
end Add_RACW_Read_Attribute;
------------------------------
Stub_Type : Entity_Id;
Stub_Type_Access : Entity_Id;
RPC_Receiver : Node_Id;
- Declarations : List_Id)
+ Body_Decls : List_Id)
is
Body_Node : Node_Id;
Proc_Decl : Node_Id;
Attr_Decl : Node_Id;
- Statements : List_Id;
+ Statements : constant List_Id := New_List;
Local_Statements : List_Id;
Remote_Statements : List_Id;
Null_Statements : List_Id;
- Procedure_Name : constant Name_Id := New_Internal_Name ('R');
+ Pnam : constant Entity_Id := Make_Temporary (Loc, 'R');
begin
+ Build_Stream_Procedure
+ (Loc, RACW_Type, Body_Node, Pnam, Statements, Outp => False);
+
+ Proc_Decl := Make_Subprogram_Declaration (Loc,
+ Copy_Specification (Loc, Specification (Body_Node)));
+
+ Attr_Decl :=
+ Make_Attribute_Definition_Clause (Loc,
+ Name => New_Occurrence_Of (RACW_Type, Loc),
+ Chars => Name_Write,
+ Expression =>
+ New_Occurrence_Of (
+ Defining_Unit_Name (Specification (Proc_Decl)), Loc));
+
+ Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
+ Insert_After (Proc_Decl, Attr_Decl);
+
+ if No (Body_Decls) then
+ return;
+ end if;
+
-- Build the code fragment corresponding to the marshalling of a
-- local object.
-- a remote object.
Remote_Statements := New_List (
-
Pack_Node_Into_Stream_Access (Loc,
- Stream => Stream_Parameter,
- Object =>
+ 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)),
+ 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)),
+ 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)),
+ 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
Object => Make_Integer_Literal (Loc, Uint_0),
Etyp => RTE (RE_Unsigned_64)));
- Statements := New_List (
+ Append_To (Statements,
Make_Implicit_If_Statement (RACW_Type,
Condition =>
Make_Op_Eq (Loc,
Left_Opnd => Object,
Right_Opnd => Make_Null (Loc)),
+
Then_Statements => Null_Statements,
+
Elsif_Parts => New_List (
Make_Elsif_Part (Loc,
Condition =>
Make_Attribute_Reference (Loc,
Prefix => Object,
Attribute_Name => Name_Tag),
+
Right_Opnd =>
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Stub_Type, Loc),
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);
+ Append_To (Body_Decls, Body_Node);
end Add_RACW_Write_Attribute;
------------------------
Proc_Decls : List_Id;
Proc_Statements : List_Id;
- Origin : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- Chars => New_Internal_Name ('P'));
+ Origin : constant Entity_Id := Make_Temporary (Loc, 'P');
-- Additional local variables for the local case
- Proxy_Addr : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- Chars => New_Internal_Name ('P'));
+ Proxy_Addr : constant Entity_Id := Make_Temporary (Loc, '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'));
+ Local_Stub : constant Entity_Id := Make_Temporary (Loc, 'L');
+ Stub_Ptr : constant Entity_Id := Make_Temporary (Loc, 'S');
function Set_Field
(Field_Name : Name_Id;
begin
Proc_Decls := New_List (
- -- Common declarations
+ -- Common declarations
Make_Object_Declaration (Loc,
Defining_Identifier => Origin,
Parameter_Associations => New_List (
New_Occurrence_Of (Package_Name, Loc)))),
- -- Declaration use only in the local case: proxy address
+ -- 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.
+ -- Declarations used only in the remote case: stub object and
+ -- stub pointer.
Make_Object_Declaration (Loc,
Defining_Identifier => Local_Stub,
Attribute_Name => Name_Unchecked_Access)));
Set_Etype (Stub_Ptr, Stub_Elements.Stub_Type_Access);
- -- Build_Get_Unique_RP_Call needs this information
+
+ -- Build_Get_Unique_RP_Call needs above information
-- Note: Here we assume that the Fat_Type is a record
-- containing just a pointer to a proxy or stub object.
-- end if;
Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of (RTE (RE_Get_RAS_Info), 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),
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,
+ Make_Simple_Return_Statement (Loc,
Unchecked_Convert_To (Fat_Type,
OK_Convert_To (RTE (RE_Address),
New_Occurrence_Of (Proxy_Addr, Loc)))))),
Set_Field (Name_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.
+ -- 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.
+ -- Asynch_P is true when the procedure is asynchronous;
+ -- Asynch_T is true when the type is asynchronous.
Set_Field (Name_Asynchronous,
Make_Or_Else (Loc,
-- Return the newly created value
Append_To (Proc_Statements,
- Make_Return_Statement (Loc,
+ Make_Simple_Return_Statement (Loc,
Expression =>
Unchecked_Convert_To (Fat_Type,
New_Occurrence_Of (Stub_Ptr, Loc))));
Parameter_Type =>
New_Occurrence_Of (Standard_Boolean, Loc))),
- Subtype_Mark =>
+ Result_Definition =>
New_Occurrence_Of (Fat_Type, Loc));
-- Set the kind and return type of the function to prevent
(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;
procedure Add_Receiving_Stubs_To_Declarations
(Pkg_Spec : Node_Id;
- Decls : List_Id)
+ Decls : List_Id;
+ Stmts : List_Id)
is
Loc : constant Source_Ptr := Sloc (Pkg_Spec);
Request_Parameter : Node_Id;
Pkg_RPC_Receiver : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- New_Internal_Name ('H'));
+ Make_Temporary (Loc, 'H');
Pkg_RPC_Receiver_Statements : List_Id;
Pkg_RPC_Receiver_Cases : constant List_Id := New_List;
Pkg_RPC_Receiver_Body : Node_Id;
-- A Pkg_RPC_Receiver is built to decode the request
- Lookup_RAS_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.
+ Lookup_RAS : Node_Id;
+ Lookup_RAS_Info : constant Entity_Id := Make_Temporary (Loc, 'R');
+ -- A remote subprogram is created to allow peers to look up RAS
+ -- information using subprogram ids.
Subp_Id : Entity_Id;
Subp_Index : Entity_Id;
-- Subprogram_Id as read from the incoming stream
- Current_Declaration : Node_Id;
- Current_Subprogram_Number : Int := First_RCI_Subprogram_Id;
- Current_Stubs : Node_Id;
+ Current_Subp_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;
+ Subp_Info_Array : constant Entity_Id := Make_Temporary (Loc, 'I');
+ Subp_Info_List : constant List_Id := New_List;
Register_Pkg_Actuals : constant List_Id := New_List;
-- associating Subprogram_Number with the subprogram declared
-- by Declaration, for which we have receiving stubs in Stubs.
+ procedure Visit_Subprogram (Decl : Node_Id);
+ -- Generate receiving stub for one remote subprogram
+
---------------------
-- Append_Stubs_To --
---------------------
New_List (
Make_Procedure_Call_Statement (Loc,
Name =>
- New_Occurrence_Of (
- Defining_Entity (Stubs), Loc),
+ New_Occurrence_Of (Defining_Entity (Stubs), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Request_Parameter, Loc))))));
end Append_Stubs_To;
+ ----------------------
+ -- Visit_Subprogram --
+ ----------------------
+
+ procedure Visit_Subprogram (Decl : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (Decl);
+ Spec : constant Node_Id := Specification (Decl);
+ Subp_Def : constant Entity_Id := Defining_Unit_Name (Spec);
+
+ Subp_Val : String_Id;
+ pragma Warnings (Off, Subp_Val);
+
+ begin
+ -- Build receiving stub
+
+ Current_Stubs :=
+ Build_Subprogram_Receiving_Stubs
+ (Vis_Decl => Decl,
+ Asynchronous =>
+ Nkind (Spec) = N_Procedure_Specification
+ and then Is_Asynchronous (Subp_Def));
+
+ Append_To (Decls, Current_Stubs);
+ Analyze (Current_Stubs);
+
+ -- Build RAS proxy
+
+ Add_RAS_Proxy_And_Analyze (Decls,
+ Vis_Decl => Decl,
+ All_Calls_Remote_E => All_Calls_Remote_E,
+ Proxy_Object_Addr => Proxy_Object_Addr);
+
+ -- Compute distribution identifier
+
+ Assign_Subprogram_Identifier
+ (Subp_Def, Current_Subp_Number, Subp_Val);
+
+ pragma Assert (Current_Subp_Number = Get_Subprogram_Id (Subp_Def));
+
+ -- Add subprogram descriptor (RCI_Subp_Info) to the subprograms
+ -- table for this receiver. This aggregate must be kept consistent
+ -- with the declaration of RCI_Subp_Info in
+ -- System.Partition_Interface.
+
+ Append_To (Subp_Info_List,
+ Make_Component_Association (Loc,
+ Choices => New_List (
+ Make_Integer_Literal (Loc, Current_Subp_Number)),
+
+ Expression =>
+ Make_Aggregate (Loc,
+ Component_Associations => New_List (
+
+ -- Addr =>
+
+ Make_Component_Association (Loc,
+ Choices =>
+ New_List (Make_Identifier (Loc, Name_Addr)),
+ Expression =>
+ New_Occurrence_Of (Proxy_Object_Addr, Loc))))));
+
+ Append_Stubs_To (Pkg_RPC_Receiver_Cases,
+ Stubs => Current_Stubs,
+ Subprogram_Number => Current_Subp_Number);
+
+ Current_Subp_Number := Current_Subp_Number + 1;
+ end Visit_Subprogram;
+
+ procedure Visit_Spec is new Build_Package_Stubs (Visit_Subprogram);
+
-- Start of processing for Add_Receiving_Stubs_To_Declarations
begin
-- - 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
+ -- and will dispatch the call to the right subprogram;
- -- - a receiving stub for any subprogram visible in the package
+ -- - a receiving stub for each subprogram visible in the package
-- spec. This stub will read all the parameters from the stream,
-- and put the result as well as the exception occurrence in the
- -- output stream
+ -- 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
+ -- by calling System.Partition_Interface.Register_Receiving_Stub.
Build_RPC_Receiver_Body (
RPC_Receiver => Pkg_RPC_Receiver,
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 =>
Make_Selected_Component (Loc,
Prefix => Request_Parameter,
Selector_Name => Name_Params))))),
- Selector_Name =>
- Make_Identifier (Loc, Name_Subp_Id))))));
+
+ Selector_Name => Make_Identifier (Loc, Name_Subp_Id))))));
-- Build a subprogram for RAS information lookups
- Current_Declaration :=
+ Lookup_RAS :=
Make_Subprogram_Declaration (Loc,
Specification =>
Make_Function_Specification (Loc,
True,
Parameter_Type =>
New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc))),
- Subtype_Mark =>
+ Result_Definition =>
New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)));
- Append_To (Decls, Current_Declaration);
- Analyze (Current_Declaration);
+ Append_To (Decls, Lookup_RAS);
+ Analyze (Lookup_RAS);
Current_Stubs := Build_Subprogram_Receiving_Stubs
- (Vis_Decl => Current_Declaration,
+ (Vis_Decl => Lookup_RAS,
Asynchronous => False);
Append_To (Decls, Current_Stubs);
Analyze (Current_Stubs);
Append_Stubs_To (Pkg_RPC_Receiver_Cases,
- Stubs =>
- Current_Stubs,
+ 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)));
+ 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;
+ Visit_Spec (Pkg_Spec);
-- If we receive an invalid Subprogram_Id, it is best to do nothing
-- rather than raising an exception since we do not want someone
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))));
+ 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),
+ Expression => New_Occurrence_Of (Subp_Id, Loc),
Alternatives => Pkg_RPC_Receiver_Cases));
Append_To (Decls,
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));
+ Intval =>
+ First_RCI_Subprogram_Id
+ + List_Length (Subp_Info_List) - 1)))))));
- 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));
+ -- For a degenerate RCI with no visible subprograms, Subp_Info_List
+ -- has zero length, and the declaration is for an empty array, in
+ -- which case no initialization aggregate must be generated.
- Append_To (Decls, Pkg_RPC_Receiver_Body);
- Analyze (Last (Decls));
+ if Present (First (Subp_Info_List)) then
+ Set_Expression (Last (Decls),
+ Make_Aggregate (Loc,
+ Component_Associations => Subp_Info_List));
- Get_Library_Unit_Name_String (Pkg_Spec);
- Append_To (Register_Pkg_Actuals,
- -- Name
- Make_String_Literal (Loc,
- Strval => String_From_Name_Buffer));
+ -- No initialization provided: remove CONSTANT so that the
+ -- declaration is not an incomplete deferred constant.
- Append_To (Register_Pkg_Actuals,
- -- Receiver
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (Pkg_RPC_Receiver, Loc),
- Attribute_Name =>
- Name_Unrestricted_Access));
+ else
+ Set_Constant_Present (Last (Decls), False);
+ end if;
+
+ Analyze (Last (Decls));
+
+ declare
+ Subp_Info_Addr : Node_Id;
+ -- Return statement for Lookup_RAS_Info: address of the subprogram
+ -- information record for the requested subprogram id.
+
+ begin
+ if Present (First (Subp_Info_List)) then
+ Subp_Info_Addr :=
+ Make_Selected_Component (Loc,
+ Prefix =>
+ Make_Indexed_Component (Loc,
+ Prefix => New_Occurrence_Of (Subp_Info_Array, Loc),
+ Expressions => New_List (
+ Convert_To (Standard_Integer,
+ Make_Identifier (Loc, Name_Subp_Id)))),
+ Selector_Name => Make_Identifier (Loc, Name_Addr));
+
+ -- Case of no visible subprogram: just raise Constraint_Error, we
+ -- know for sure we got junk from a remote partition.
+
+ else
+ Subp_Info_Addr :=
+ Make_Raise_Constraint_Error (Loc,
+ Reason => CE_Range_Check_Failed);
+ Set_Etype (Subp_Info_Addr, RTE (RE_Unsigned_64));
+ end if;
+
+ Append_To (Decls,
+ Make_Subprogram_Body (Loc,
+ Specification =>
+ Copy_Specification (Loc, Parent (Lookup_RAS_Info)),
+ Declarations => No_List,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (
+ Make_Simple_Return_Statement (Loc,
+ Expression =>
+ OK_Convert_To
+ (RTE (RE_Unsigned_64), Subp_Info_Addr))))));
+ end;
+
+ Analyze (Last (Decls));
+
+ Append_To (Decls, Pkg_RPC_Receiver_Body);
+ Analyze (Last (Decls));
+
+ Get_Library_Unit_Name_String (Pkg_Spec);
+
+ -- Name
+
+ Append_To (Register_Pkg_Actuals,
+ Make_String_Literal (Loc,
+ Strval => String_From_Name_Buffer));
+
+ -- Receiver
+
+ Append_To (Register_Pkg_Actuals,
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Pkg_RPC_Receiver, Loc),
+ Attribute_Name => Name_Unrestricted_Access));
+
+ -- Version
Append_To (Register_Pkg_Actuals,
- -- Version
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc),
- Attribute_Name =>
- Name_Version));
+ Attribute_Name => Name_Version));
+
+ -- Subp_Info
Append_To (Register_Pkg_Actuals,
- -- Subp_Info
Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (Subp_Info_Array, Loc),
- Attribute_Name =>
- Name_Address));
+ Prefix => New_Occurrence_Of (Subp_Info_Array, Loc),
+ Attribute_Name => Name_Address));
+
+ -- Subp_Info_Len
Append_To (Register_Pkg_Actuals,
- -- Subp_Info_Len
Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (Subp_Info_Array, Loc),
- Attribute_Name =>
- Name_Length));
+ Prefix => New_Occurrence_Of (Subp_Info_Array, Loc),
+ Attribute_Name => Name_Length));
- Append_To (Decls,
+ -- Generate the call
+
+ Append_To (Stmts,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Register_Receiving_Stub), Loc),
Parameter_Associations => Register_Pkg_Actuals));
- Analyze (Last (Decls));
+ Analyze (Last (Stmts));
end Add_Receiving_Stubs_To_Declarations;
---------------------------------
Loc : constant Source_Ptr := Sloc (Nod);
Stream_Parameter : Node_Id;
- -- Name of the stream used to transmit parameters to the
- -- remote package.
+ -- 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
-- 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:
-- 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'));
+ Stream_Parameter := Make_Temporary (Loc, 'S');
Append_To (Decls,
Make_Object_Declaration (Loc,
New_List (Make_Integer_Literal (Loc, 0))))));
if not Is_Known_Asynchronous then
- Result_Parameter :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
+ Result_Parameter := Make_Temporary (Loc, 'R');
Append_To (Decls,
Make_Object_Declaration (Loc,
Constraints =>
New_List (Make_Integer_Literal (Loc, 0))))));
- Exception_Return_Parameter :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
+ Exception_Return_Parameter := Make_Temporary (Loc, 'E');
Append_To (Decls,
Make_Object_Declaration (Loc,
Attribute_Name => Name_Write,
Expressions => New_List (
Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (Stream_Parameter, Loc),
- Attribute_Name =>
- Name_Access),
+ 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
Append_To (Statements,
Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
- Attribute_Name =>
- Name_Write,
+ 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),
+ Prefix => New_Occurrence_Of (Stream_Parameter, Loc),
Attribute_Name => Name_Access),
Subprogram_Id)));
begin
if Is_RACW_Controlling_Formal
- (Current_Parameter, Stub_Type)
+ (Current_Parameter, Stub_Type)
then
-- In the case of a controlling formal argument, we marshall
-- its addr field rather than the local stub.
Etyp => RTE (RE_Unsigned_64)));
else
- Value := New_Occurrence_Of
- (Defining_Identifier (Current_Parameter), Loc);
+ 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
Etyp := Etype (Typ);
end if;
- Constrained :=
- Is_Constrained (Etyp) or else Is_Elementary_Type (Etyp);
+ Constrained := not Transmit_As_Unconstrained (Etyp);
-- Any parameter but unconstrained out parameters are
-- transmitted to the peer.
then
Append_To (Statements,
Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (Etyp, Loc),
+ Prefix => New_Occurrence_Of (Etyp, Loc),
Attribute_Name =>
Output_From_Constrained (Constrained),
Expressions => New_List (
-- type and push it in the stream after the regular
-- parameters.
- Extra_Parameter := Make_Defining_Identifier
- (Loc, New_Internal_Name ('P'));
+ Extra_Parameter := Make_Temporary (Loc, 'P');
Append_To (Decls,
Make_Object_Declaration (Loc,
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Standard_Boolean, Loc),
- Attribute_Name =>
- Name_Write,
+ Attribute_Name => Name_Write,
Expressions => New_List (
Make_Attribute_Reference (Loc,
Prefix =>
- New_Occurrence_Of (Stream_Parameter, Loc),
- Attribute_Name =>
+ New_Occurrence_Of
+ (Stream_Parameter, Loc), Attribute_Name =>
Name_Access),
New_Occurrence_Of (Extra_Parameter, Loc))));
end if;
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Stream_Parameter, Loc),
- Attribute_Name =>
- Name_Access))));
+ Attribute_Name => Name_Access))));
else
Asynchronous_Statements := No_List;
end if;
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Stream_Parameter, Loc),
- Attribute_Name =>
- Name_Access),
+ Attribute_Name => Name_Access),
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Result_Parameter, Loc),
- Attribute_Name =>
- Name_Access))));
+ 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
Prefix =>
New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc),
- Attribute_Name =>
- Name_Read,
+ Attribute_Name => Name_Read,
Expressions => New_List (
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Result_Parameter, Loc),
- Attribute_Name =>
- Name_Access),
+ Attribute_Name => Name_Access),
New_Occurrence_Of (Exception_Return_Parameter, Loc))));
Append_To (Non_Asynchronous_Statements,
Append_To (Non_Asynchronous_Statements,
Make_Tag_Check (Loc,
- Make_Return_Statement (Loc,
+ Make_Simple_Return_Statement (Loc,
Expression =>
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (
- Etype (Subtype_Mark (Spec)), Loc),
+ Etype (Result_Definition (Spec)), Loc),
Attribute_Name => Name_Input,
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.
+ -- 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
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Result_Parameter, Loc),
- Attribute_Name =>
- Name_Access),
+ Attribute_Name => Name_Access),
Value)));
end if;
end;
(RPC_Receiver => RPC_Receiver,
Request_Parameter => Request);
- Subp_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
+ Subp_Id := Make_Temporary (Loc, 'P');
Subp_Index := Subp_Id;
-- Subp_Id may not be a constant, because in the case of the RPC
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)))));
+ Make_Selected_Component (Loc,
+ Prefix => Request,
+ Selector_Name => Name_Params)))));
Stmts := New_List;
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'));
+ Target_Info.Partition := Make_Temporary (Loc, 'P');
+
if Present (Controlling_Parameter) then
Append_To (Decls,
Make_Object_Declaration (Loc,
procedure Build_Stub_Type
(RACW_Type : Entity_Id;
- Stub_Type : Entity_Id;
- Stub_Type_Decl : out Node_Id;
+ Stub_Type_Comps : out List_Id;
RPC_Receiver_Decl : out Node_Id)
is
- Loc : constant Source_Ptr := Sloc (Stub_Type);
+ Loc : constant Source_Ptr := Sloc (RACW_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)))))));
+ Stub_Type_Comps := 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;
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));
+ Build_RPC_Receiver_Specification
+ (RPC_Receiver => Make_Temporary (Loc, 'R'),
+ Request_Parameter => RPC_Receiver_Request));
end;
end if;
end Build_Stub_Type;
is
Loc : constant Source_Ptr := Sloc (Vis_Decl);
- Request_Parameter : Node_Id;
- -- ???
+ Request_Parameter : constant Entity_Id := Make_Temporary (Loc, 'R');
+ -- Formal parameter for receiving stubs: a descriptor for an incoming
+ -- request.
Decls : constant List_Id := New_List;
-- All the parameters will get declared before calling the real
begin
if Present (RACW_Type) then
- Called_Subprogram :=
- New_Occurrence_Of (Parent_Primitive, Loc);
+ Called_Subprogram := New_Occurrence_Of (Parent_Primitive, Loc);
else
Called_Subprogram :=
- New_Occurrence_Of (
- Defining_Unit_Name (Specification (Vis_Decl)), Loc);
+ 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'));
+ Dynamic_Async := Make_Temporary (Loc, 'S');
else
Dynamic_Async := Empty;
end if;
if not Asynchronous or Dynamically_Asynchronous then
-- The first statement after the subprogram call is a statement to
- -- writes a Null_Occurrence into the result stream.
+ -- write a Null_Occurrence into the result stream.
Null_Raise_Statement :=
Make_Attribute_Reference (Loc,
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),
+ Make_Selected_Component (Loc,
+ Prefix => Request_Parameter,
+ Selector_Name => Name_Result),
New_Occurrence_Of (RTE (RE_Null_Occurrence), Loc)));
if Dynamically_Asynchronous then
Etyp : Entity_Id;
Constrained : Boolean;
- Object : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- New_Internal_Name ('P'));
+ Need_Extra_Constrained : Boolean;
+ -- True when an Extra_Constrained actual is required
- Expr : Node_Id := Empty;
+ Object : constant Entity_Id := Make_Temporary (Loc, 'P');
+
+ Expr : Node_Id := Empty;
Is_Controlling_Formal : constant Boolean :=
Is_RACW_Controlling_Formal
(Current_Parameter, Stub_Type);
begin
- Set_Ekind (Object, E_Variable);
-
if Is_Controlling_Formal then
-- We have a controlling formal parameter. Read its address
Etyp := Etype (Parameter_Type (Current_Parameter));
end if;
- Constrained :=
- Is_Constrained (Etyp) or else Is_Elementary_Type (Etyp);
+ Constrained := not Transmit_As_Unconstrained (Etyp);
if In_Present (Current_Parameter)
or else not Out_Present (Current_Parameter)
or else not Constrained
or else Is_Controlling_Formal
then
- -- If an input parameter is 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 an input parameter is constrained, then the read of
+ -- the parameter is deferred until the beginning of the
+ -- subprogram body. If it is unconstrained, then an
+ -- expression is built for the object declaration and the
+ -- variable is set using 'Input instead of 'Read. Note that
+ -- this deferral does not change the order in which the
+ -- actuals are read because Build_Ordered_Parameter_List
+ -- puts them unconstrained first.
- if Constrained and then not Is_Controlling_Formal then
+ if Constrained then
Append_To (Statements,
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Etyp, Loc),
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));
+
+ -- Build and append Input_With_Tag_Check function
+
+ Append_To (Decls,
+ Input_With_Tag_Check (Loc,
+ Var_Type => Etyp,
+ Stream =>
+ Make_Selected_Component (Loc,
+ Prefix => Request_Parameter,
+ Selector_Name => Name_Params)));
+
+ -- Prepare function call expression
+
+ Expr :=
+ Make_Function_Call (Loc,
+ Name =>
+ New_Occurrence_Of
+ (Defining_Unit_Name
+ (Specification (Last (Decls))), Loc));
end if;
end if;
- -- 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));
+ Need_Extra_Constrained :=
+ Nkind (Parameter_Type (Current_Parameter)) /=
+ N_Access_Definition
+ and then
+ Ekind (Defining_Identifier (Current_Parameter)) /= E_Void
+ and then
+ Present (Extra_Constrained
+ (Defining_Identifier (Current_Parameter)));
+
+ -- We may not associate an extra constrained actual to a
+ -- constant object, so if one is needed, declare the actual
+ -- as a variable even if it won't be modified.
+
+ Build_Actual_Object_Declaration
+ (Object => Object,
+ Etyp => Etyp,
+ Variable => Need_Extra_Constrained
+ or else Out_Present (Current_Parameter),
+ Expr => Expr,
+ Decls => Decls);
-- An out parameter may be written back using a 'Write
-- attribute instead of a 'Output because it has been
-- 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
+ if Need_Extra_Constrained then
declare
Extra_Parameter : constant Entity_Id :=
Extra_Constrained
Prefix => Request_Parameter,
Selector_Name => Name_Params),
New_Occurrence_Of (Formal_Entity, Loc))));
+
+ -- Note: the call to Set_Extra_Constrained below relies
+ -- on the fact that Object's Ekind has been set by
+ -- Build_Actual_Object_Declaration.
+
Set_Extra_Constrained (Object, Formal_Entity);
end;
end if;
declare
Etyp : constant Entity_Id :=
- Etype (Subtype_Mark (Specification (Vis_Decl)));
- Result : constant Node_Id :=
- Make_Defining_Identifier (Loc,
- New_Internal_Name ('R'));
+ Etype (Result_Definition (Specification (Vis_Decl)));
+ Result : constant Node_Id := Make_Temporary (Loc, 'R');
+
begin
Inner_Decls := New_List (
Make_Object_Declaration (Loc,
Name => Called_Subprogram,
Parameter_Associations => Parameter_List)));
+ if Is_Class_Wide_Type (Etyp) then
+
+ -- For a remote call to a function with a class-wide type,
+ -- check that the returned value satisfies the requirements
+ -- of E.4(18).
+
+ Append_To (Inner_Decls,
+ Make_Transportable_Check (Loc,
+ New_Occurrence_Of (Result, Loc)));
+
+ end if;
+
Append_To (After_Statements,
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Etyp, Loc),
-- For an asynchronous procedure, add a null exception handler
Excep_Handlers := New_List (
- Make_Exception_Handler (Loc,
+ Make_Implicit_Exception_Handler (Loc,
Exception_Choices => New_List (Make_Others_Choice (Loc)),
Statements => New_List (Make_Null_Statement (Loc))));
-- 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_Choice := Make_Temporary (Loc, 'E');
Excep_Code := New_List (
Make_Attribute_Reference (Loc,
end if;
Excep_Handlers := New_List (
- Make_Exception_Handler (Loc,
+ Make_Implicit_Exception_Handler (Loc,
Choice_Parameter => Excep_Choice,
Exception_Choices => New_List (Make_Others_Choice (Loc)),
Statements => Excep_Code));
Subp_Spec :=
Make_Procedure_Specification (Loc,
- Defining_Unit_Name =>
- Make_Defining_Identifier (Loc, New_Internal_Name ('F')),
+ Defining_Unit_Name => Make_Temporary (Loc, 'F'),
Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc,
end GARLIC_Support;
- -----------------------------
- -- Make_Selected_Component --
- -----------------------------
+ -------------------------------
+ -- Get_And_Reset_RACW_Bodies --
+ -------------------------------
+
+ function Get_And_Reset_RACW_Bodies (RACW_Type : Entity_Id) return List_Id is
+ Desig : constant Entity_Id :=
+ Etype (Designated_Type (RACW_Type));
+
+ Stub_Elements : Stub_Structure := Stubs_Table.Get (Desig);
+
+ Body_Decls : List_Id;
+ -- Returned list of declarations
- 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;
+ if Stub_Elements = Empty_Stub_Structure then
+
+ -- Stub elements may be missing as a consequence of a previously
+ -- detected error.
+
+ return No_List;
+ end if;
+
+ Body_Decls := Stub_Elements.Body_Decls;
+ Stub_Elements.Body_Decls := No_List;
+ Stubs_Table.Set (Desig, Stub_Elements);
+ return Body_Decls;
+ end Get_And_Reset_RACW_Bodies;
+
+ -----------------------
+ -- Get_Stub_Elements --
+ -----------------------
+
+ function Get_Stub_Elements (RACW_Type : Entity_Id) return Stub_Structure is
+ Desig : constant Entity_Id :=
+ Etype (Designated_Type (RACW_Type));
+ Stub_Elements : constant Stub_Structure := Stubs_Table.Get (Desig);
+ begin
+ pragma Assert (Stub_Elements /= Empty_Stub_Structure);
+ return Stub_Elements;
+ end Get_Stub_Elements;
-----------------------
-- Get_Subprogram_Id --
-----------------------
function Get_Subprogram_Id (Def : Entity_Id) return String_Id is
+ Result : constant String_Id := Get_Subprogram_Ids (Def).Str_Identifier;
begin
- return Get_Subprogram_Ids (Def).Str_Identifier;
+ pragma Assert (Result /= No_String);
+ return Result;
end Get_Subprogram_Id;
-----------------------
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;
+ return Subprogram_Identifier_Table.Get (Def);
end Get_Subprogram_Ids;
----------
begin
return
Make_Subprogram_Body (Loc,
- Specification => Make_Function_Specification (Loc,
- Defining_Unit_Name =>
- Make_Defining_Identifier (Loc, New_Internal_Name ('S')),
- Subtype_Mark => New_Occurrence_Of (Var_Type, Loc)),
+ Specification =>
+ Make_Function_Specification (Loc,
+ Defining_Unit_Name => Make_Temporary (Loc, 'S'),
+ Result_Definition => New_Occurrence_Of (Var_Type, Loc)),
Declarations => No_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc, New_List (
Make_Tag_Check (Loc,
- Make_Return_Statement (Loc,
+ Make_Simple_Return_Statement (Loc,
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Var_Type, Loc),
Attribute_Name => Name_Input,
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 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 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;
or else Etype (Typ) = Stub_Type;
end Is_RACW_Controlling_Formal;
+ ------------------------------
+ -- Make_Transportable_Check --
+ ------------------------------
+
+ function Make_Transportable_Check
+ (Loc : Source_Ptr;
+ Expr : Node_Id) return Node_Id is
+ begin
+ return
+ Make_Raise_Program_Error (Loc,
+ Condition =>
+ Make_Op_Not (Loc,
+ Build_Get_Transportable (Loc,
+ Make_Selected_Component (Loc,
+ Prefix => Expr,
+ Selector_Name => Make_Identifier (Loc, Name_uTag)))),
+ Reason => PE_Non_Transportable_Actual);
+ end Make_Transportable_Check;
+
+ -----------------------------
+ -- Make_Selected_Component --
+ -----------------------------
+
+ function Make_Selected_Component
+ (Loc : Source_Ptr;
+ Prefix : Entity_Id;
+ Selector_Name : Name_Id) return Node_Id
+ is
+ begin
+ return Make_Selected_Component (Loc,
+ Prefix => New_Occurrence_Of (Prefix, Loc),
+ Selector_Name => Make_Identifier (Loc, Selector_Name));
+ end Make_Selected_Component;
+
--------------------
-- Make_Tag_Check --
--------------------
function Make_Tag_Check (Loc : Source_Ptr; N : Node_Id) return Node_Id is
- Occ : constant Entity_Id :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
+ Occ : constant Entity_Id := Make_Temporary (Loc, 'E');
begin
return Make_Block_Statement (Loc,
Statements => New_List (N),
Exception_Handlers => New_List (
- Make_Exception_Handler (Loc,
+ Make_Implicit_Exception_Handler (Loc,
Choice_Parameter => Occ,
Exception_Choices =>
(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.
+ Body_Decls : List_Id);
+ -- Add Read attribute for the RACW type. The declaration and attribute
+ -- definition clauses are inserted right after the declaration of
+ -- RACW_Type. If Body_Decls is not No_List, the subprogram body is
+ -- appended to it (case where the RACW declaration is in the main unit).
procedure Add_RACW_Write_Attribute
(RACW_Type : Entity_Id;
Stub_Type : Entity_Id;
Stub_Type_Access : Entity_Id;
- Declarations : List_Id);
- -- Same thing for the Write attribute
+ Body_Decls : List_Id);
+ -- Same as above 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);
+ Body_Decls : 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);
+ (RACW_Type : Entity_Id;
+ Body_Decls : List_Id);
-- Add the To_Any TSS for this RACW type
procedure Add_RACW_TypeCode
(Designated_Type : Entity_Id;
RACW_Type : Entity_Id;
- Declarations : List_Id);
+ Body_Decls : List_Id);
-- Add the TypeCode TSS for this RACW type
procedure Add_RAS_From_Any (RAS_Type : Entity_Id);
-- Name
Make_String_Literal (Loc,
- Full_Qualified_Name (Desig)),
+ Fully_Qualified_Name_String (Desig)),
-- Handler
Stub_Type : Entity_Id;
Stub_Type_Access : Entity_Id;
RPC_Receiver_Decl : Node_Id;
- Declarations : List_Id)
+ Body_Decls : List_Id)
is
- pragma Warnings (Off);
pragma Unreferenced (RPC_Receiver_Decl);
- pragma Warnings (On);
begin
Add_RACW_From_Any
(RACW_Type => RACW_Type,
- Stub_Type => Stub_Type,
- Stub_Type_Access => Stub_Type_Access,
- Declarations => Declarations);
+ Body_Decls => Body_Decls);
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.
+ (RACW_Type => RACW_Type,
+ Body_Decls => Body_Decls);
Add_RACW_Write_Attribute
(RACW_Type => RACW_Type,
Stub_Type => Stub_Type,
Stub_Type_Access => Stub_Type_Access,
- Declarations => Declarations);
+ Body_Decls => Body_Decls);
Add_RACW_Read_Attribute
(RACW_Type => RACW_Type,
Stub_Type => Stub_Type,
Stub_Type_Access => Stub_Type_Access,
- Declarations => Declarations);
+ Body_Decls => Body_Decls);
Add_RACW_TypeCode
(Designated_Type => Desig,
RACW_Type => RACW_Type,
- Declarations => Declarations);
+ Body_Decls => Body_Decls);
end Add_RACW_Features;
-----------------------
procedure Add_RACW_From_Any
(RACW_Type : Entity_Id;
- Stub_Type : Entity_Id;
- Stub_Type_Access : Entity_Id;
- Declarations : List_Id)
+ Body_Decls : List_Id)
is
Loc : constant Source_Ptr := Sloc (RACW_Type);
Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
-
Fnam : constant Entity_Id :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('F'));
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Chars (RACW_Type), '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.
+ Any_Parameter : constant Entity_Id :=
+ Make_Defining_Identifier (Loc, Name_A);
Asynchronous_Flag : constant Entity_Id :=
Asynchronous_Flags_Table.Get (RACW_Type);
-- The flag object declared in Add_RACW_Asynchronous_Flag
begin
- -- 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)),
+ 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));
- 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)),
+ -- NOTE: The usage occurrences of RACW_Parameter must refer to the
+ -- entity in the declaration spec, not those of the body spec.
- Make_Object_Declaration (Loc,
- Defining_Identifier => Is_Local,
- Object_Definition =>
- New_Occurrence_Of (Standard_Boolean, Loc)),
+ Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec);
+ Insert_After (Declaration_Node (RACW_Type), Func_Decl);
+ Set_Renaming_TSS (RACW_Type, Fnam, TSS_From_Any);
- Make_Object_Declaration (Loc,
- Defining_Identifier => Addr,
- Object_Definition =>
- New_Occurrence_Of (RTE (RE_Address), Loc)));
+ if No (Body_Decls) then
+ return;
+ end if;
- -- 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
+ -- ??? Issue with asynchronous calls here: the Asynchronous flag is
+ -- set on the stub type if, and only if, the RACW type has a pragma
+ -- Asynchronous. This is incorrect for RACWs that implement RAS
+ -- types, because in that case the /designated subprogram/ (not the
+ -- type) might be asynchronous, and that causes the stub to need to
+ -- be asynchronous too. A solution is to transport a RAS as a struct
+ -- containing a RACW and an asynchronous flag, and to properly alter
+ -- the Asynchronous component in the stub type in the RAS's _From_Any
+ -- TSS.
Statements := New_List (
- Make_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_Simple_Return_Statement (Loc,
+ Expression => Unchecked_Convert_To (RACW_Type,
Make_Function_Call (Loc,
- Name =>
- New_Occurrence_Of (RTE (RE_Entity_Of), Loc),
+ Name => New_Occurrence_Of (RTE (RE_Get_RACW), 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))),
- Subtype_Mark => 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);
+ Make_Function_Call (Loc,
+ Name => New_Occurrence_Of (RTE (RE_FA_ObjRef), Loc),
+ Parameter_Associations => New_List (
+ New_Occurrence_Of (Any_Parameter, Loc))),
+ Build_Stub_Tag (Loc, RACW_Type),
+ New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc),
+ New_Occurrence_Of (Asynchronous_Flag, Loc))))));
Func_Body :=
Make_Subprogram_Body (Loc,
- Specification =>
- Copy_Specification (Loc, Func_Spec),
- Declarations => Decls,
+ Specification => Copy_Specification (Loc, Func_Spec),
+ Declarations => No_List,
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);
+ Append_To (Body_Decls, Func_Body);
end Add_RACW_From_Any;
-----------------------------
(RACW_Type : Entity_Id;
Stub_Type : Entity_Id;
Stub_Type_Access : Entity_Id;
- Declarations : List_Id)
+ Body_Decls : List_Id)
is
- pragma Warnings (Off);
pragma Unreferenced (Stub_Type, Stub_Type_Access);
- pragma Warnings (On);
+
Loc : constant Source_Ptr := Sloc (RACW_Type);
Proc_Decl : Node_Id;
Body_Node : Node_Id;
- Decls : List_Id;
- Statements : List_Id;
+ Decls : constant List_Id := New_List;
+ Statements : constant List_Id := New_List;
+ Reference : constant Entity_Id :=
+ Make_Defining_Identifier (Loc, Name_R);
-- Various parts of the procedure
- Procedure_Name : constant Name_Id :=
- New_Internal_Name ('R');
- Source_Ref : constant Entity_Id :=
- Make_Defining_Identifier
- (Loc, New_Internal_Name ('R'));
+ Pnam : constant Entity_Id := Make_Temporary (Loc, 'R');
+
+ Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
+
Asynchronous_Flag : constant Entity_Id :=
Asynchronous_Flags_Table.Get (RACW_Type);
pragma Assert (Present (Asynchronous_Flag));
function Stream_Parameter return Node_Id;
function Result return Node_Id;
+
-- Functions to create occurrences of the formal parameter names
------------
-- Start of processing for Add_RACW_Read_Attribute
begin
- -- Generate object declarations
+ Build_Stream_Procedure
+ (Loc, RACW_Type, Body_Node, Pnam, Statements, Outp => True);
- Decls := New_List (
+ Proc_Decl := Make_Subprogram_Declaration (Loc,
+ Copy_Specification (Loc, Specification (Body_Node)));
+
+ Attr_Decl :=
+ Make_Attribute_Definition_Clause (Loc,
+ Name => New_Occurrence_Of (RACW_Type, Loc),
+ Chars => Name_Read,
+ Expression =>
+ New_Occurrence_Of (
+ Defining_Unit_Name (Specification (Proc_Decl)), Loc));
+
+ Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
+ Insert_After (Proc_Decl, Attr_Decl);
+
+ if No (Body_Decls) then
+ return;
+ end if;
+
+ Append_To (Decls,
Make_Object_Declaration (Loc,
- Defining_Identifier => Source_Ref,
- Object_Definition =>
+ Defining_Identifier =>
+ Reference,
+ Object_Definition =>
New_Occurrence_Of (RTE (RE_Object_Ref), Loc)));
- Statements := New_List (
+ Append_List_To (Statements, New_List (
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (RTE (RE_Object_Ref), Loc),
Attribute_Name => Name_Read,
Expressions => New_List (
Stream_Parameter,
- New_Occurrence_Of (Source_Ref, Loc))),
+ New_Occurrence_Of (Reference, Loc))),
+
Make_Assignment_Statement (Loc,
- Name =>
+ Name =>
Result,
Expression =>
- PolyORB_Support.Helpers.Build_From_Any_Call (
- RACW_Type,
+ Unchecked_Convert_To (RACW_Type,
Make_Function_Call (Loc,
- Name =>
- New_Occurrence_Of (RTE (RE_TA_ObjRef), Loc),
+ Name =>
+ New_Occurrence_Of (RTE (RE_Get_RACW), Loc),
Parameter_Associations => New_List (
- New_Occurrence_Of (Source_Ref, Loc))),
- Decls)));
+ New_Occurrence_Of (Reference, Loc),
+ Build_Stub_Tag (Loc, RACW_Type),
+ New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc),
+ New_Occurrence_Of (Asynchronous_Flag, Loc)))))));
- 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);
+ Append_To (Body_Decls, Body_Node);
end Add_RACW_Read_Attribute;
---------------------
---------------------
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)
+ (RACW_Type : Entity_Id;
+ Body_Decls : List_Id)
is
Loc : constant Source_Ptr := Sloc (RACW_Type);
- Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
+ Fnam : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Chars (RACW_Type), 'T'));
- Fnam : Entity_Id;
+ Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
Stub_Elements : constant Stub_Structure :=
- Stubs_Table.Get (Designated_Type);
- pragma Assert (Stub_Elements /= Empty_Stub_Structure);
+ Get_Stub_Elements (RACW_Type);
Func_Spec : Node_Id;
Func_Decl : Node_Id;
Func_Body : Node_Id;
- Decls : List_Id;
- Statements : List_Id;
- Null_Statements : List_Id;
- Local_Statements : List_Id := No_List;
- Stub_Statements : List_Id;
- If_Node : Node_Id;
+ Decls : List_Id;
+ Statements : List_Id;
-- Various parts of the subprogram
- RACW_Parameter : constant Entity_Id
- := Make_Defining_Identifier (Loc, Name_R);
+ 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'));
+ Reference : constant Entity_Id := Make_Temporary (Loc, 'R');
+ Any : constant Entity_Id := Make_Temporary (Loc, '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.)
+ 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));
- Null_Statements := New_List (Make_Null_Statement (Loc));
+ -- NOTE: The usage occurrences of RACW_Parameter must refer to the
+ -- entity in the declaration spec, not in the body spec.
- if Is_RAS then
+ Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec);
- -- If the object is a RAS designating a local subprogram,
- -- we already have a target reference.
+ Insert_After (Declaration_Node (RACW_Type), Func_Decl);
+ Set_Renaming_TSS (RACW_Type, Fnam, TSS_To_Any);
- 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)))));
+ if No (Body_Decls) then
+ return;
+ end if;
- else
- -- If the object is a local RACW object, use Get_Reference now
- -- to obtain a reference.
+ -- Generate:
- 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;
+ -- R : constant Object_Ref :=
+ -- Get_Reference
+ -- (Address!(RACW),
+ -- "typ",
+ -- Stub_Type'Tag,
+ -- Is_RAS,
+ -- RPC_Receiver'Access);
+ -- A : Any;
- -- If the object is located on another partition, use the target
- -- from the stub.
+ Decls := New_List (
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Reference,
+ Constant_Present => True,
+ Object_Definition =>
+ New_Occurrence_Of (RTE (RE_Object_Ref), Loc),
+ Expression =>
+ Make_Function_Call (Loc,
+ Name => New_Occurrence_Of (RTE (RE_Get_Reference), Loc),
+ Parameter_Associations => New_List (
+ Unchecked_Convert_To (RTE (RE_Address),
+ New_Occurrence_Of (RACW_Parameter, Loc)),
+ Make_String_Literal (Loc,
+ Strval => Fully_Qualified_Name_String
+ (Etype (Designated_Type (RACW_Type)))),
+ Build_Stub_Tag (Loc, RACW_Type),
+ New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc),
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of
+ (Defining_Identifier
+ (Stub_Elements.RPC_Receiver_Decl), Loc),
+ Attribute_Name => Name_Access)))),
- 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)))));
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Any,
+ Object_Definition => New_Occurrence_Of (RTE (RE_Any), Loc)));
- -- Distinguish between the null, local and remote cases,
- -- and execute the appropriate piece of code.
+ -- Generate:
- 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);
+ -- Any := TA_ObjRef (Reference);
+ -- Set_TC (Any, RPC_Receiver.Obj_TypeCode);
+ -- return Any;
Statements := New_List (
- If_Node,
Make_Assignment_Statement (Loc,
- Name =>
- New_Occurrence_Of (Any, 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),
+ Name => New_Occurrence_Of (RTE (RE_Set_TC), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Any, Loc),
Make_Selected_Component (Loc,
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))),
- Subtype_Mark => 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);
+ Make_Simple_Return_Statement (Loc,
+ Expression => New_Occurrence_Of (Any, Loc)));
Func_Body :=
Make_Subprogram_Body (Loc,
- Specification =>
- Copy_Specification (Loc, Func_Spec),
+ 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);
+ Append_To (Body_Decls, Func_Body);
end Add_RACW_To_Any;
-----------------------
procedure Add_RACW_TypeCode
(Designated_Type : Entity_Id;
RACW_Type : Entity_Id;
- Declarations : List_Id)
+ Body_Decls : List_Id)
is
Loc : constant Source_Ptr := Sloc (RACW_Type);
- Fnam : Entity_Id;
+ Fnam : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Chars (RACW_Type), 'Y'));
Stub_Elements : constant Stub_Structure :=
Stubs_Table.Get (Designated_Type);
Func_Decl : Node_Id;
Func_Body : Node_Id;
- RACW_Parameter : constant Entity_Id :=
- Make_Defining_Identifier (Loc, Name_R);
-
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.
+ -- 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,
- Parameter_Specifications => New_List (
- Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- RACW_Parameter,
- Parameter_Type =>
- Make_Access_Definition (Loc,
- Subtype_Mark =>
- New_Occurrence_Of (RACW_Type, Loc)))),
- Subtype_Mark => New_Occurrence_Of (RTE (RE_TypeCode), 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.
+ -- NOTE: The usage occurrences of RACW_Parameter must refer to the
+ -- entity in the declaration spec, not those of the body spec.
Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec);
+ Insert_After (Declaration_Node (RACW_Type), Func_Decl);
+ Set_Renaming_TSS (RACW_Type, Fnam, TSS_TypeCode);
+
+ if No (Body_Decls) then
+ return;
+ end if;
Func_Body :=
Make_Subprogram_Body (Loc,
- Specification =>
- Copy_Specification (Loc, Func_Spec),
+ 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,
+ Make_Simple_Return_Statement (Loc,
Expression =>
Make_Selected_Component (Loc,
Prefix =>
- Defining_Identifier (
- Stub_Elements.RPC_Receiver_Decl),
+ 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);
+ Append_To (Body_Decls, Func_Body);
end Add_RACW_TypeCode;
------------------------------
(RACW_Type : Entity_Id;
Stub_Type : Entity_Id;
Stub_Type_Access : Entity_Id;
- Declarations : List_Id)
+ Body_Decls : List_Id)
is
+ pragma Unreferenced (Stub_Type, Stub_Type_Access);
+
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);
+
+ Stub_Elements : constant Stub_Structure :=
+ Get_Stub_Elements (RACW_Type);
Body_Node : Node_Id;
Proc_Decl : Node_Id;
Attr_Decl : Node_Id;
- Statements : List_Id;
- Procedure_Name : constant Name_Id := New_Internal_Name ('R');
+ Statements : constant List_Id := New_List;
+ Pnam : constant Entity_Id := Make_Temporary (Loc, 'R');
function Stream_Parameter return Node_Id;
function Object return Node_Id;
------------
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;
+ return Make_Identifier (Loc, Name_V);
end Object;
----------------------
-- 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);
+ (Loc, RACW_Type, Body_Node, Pnam, Statements, Outp => False);
Proc_Decl :=
Make_Subprogram_Declaration (Loc,
Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
Insert_After (Proc_Decl, Attr_Decl);
- Append_To (Declarations, Body_Node);
+
+ if No (Body_Decls) then
+ return;
+ end if;
+
+ Append_To (Statements,
+ Pack_Node_Into_Stream_Access (Loc,
+ Stream => Stream_Parameter,
+ Object =>
+ Make_Function_Call (Loc,
+ Name => New_Occurrence_Of (RTE (RE_Get_Reference), Loc),
+ Parameter_Associations => New_List (
+ Unchecked_Convert_To (RTE (RE_Address), Object),
+ Make_String_Literal (Loc,
+ Strval => Fully_Qualified_Name_String
+ (Etype (Designated_Type (RACW_Type)))),
+ Build_Stub_Tag (Loc, RACW_Type),
+ New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc),
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of
+ (Defining_Identifier
+ (Stub_Elements.RPC_Receiver_Decl), Loc),
+ Attribute_Name => Name_Access))),
+
+ Etyp => RTE (RE_Object_Ref)));
+
+ Append_To (Body_Decls, Body_Node);
end Add_RACW_Write_Attribute;
-----------------------
-- corresponding record type.
RACW_Type : constant Entity_Id :=
- Underlying_RACW_Type (Ras_Type);
- Desig : constant Entity_Id :=
- Etype (Designated_Type (RACW_Type));
+ Underlying_RACW_Type (Ras_Type);
Stub_Elements : constant Stub_Structure :=
- Stubs_Table.Get (Desig);
- pragma Assert (Stub_Elements /= Empty_Stub_Structure);
+ Get_Stub_Elements (RACW_Type);
Proc : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Make_Defining_Identifier (Loc, Name_A);
-- For the call to Get_Local_Address
+ Local_Stub : constant Entity_Id := Make_Temporary (Loc, 'L');
+ Stub_Ptr : constant Entity_Id := Make_Temporary (Loc, 'S');
-- Additional local variables for the remote case
- 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;
New_Occurrence_Of (Stub_Elements.Stub_Type, Loc)),
Make_Object_Declaration (Loc,
- Defining_Identifier =>
- Stub_Ptr,
+ Defining_Identifier => Stub_Ptr,
Object_Definition =>
New_Occurrence_Of (Stub_Elements.Stub_Type_Access, Loc),
Expression =>
Proc_Statements := New_List (
Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of (RTE (RE_Get_RAS_Info), 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),
-- obtain the local address of its proxy (A).
Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of (RTE (RE_Get_Local_Address), 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),
Append_To (Proc_Statements,
- -- if L then
+ -- if L then
Make_Implicit_If_Statement (N,
- Condition =>
- New_Occurrence_Of (Is_Local, Loc),
+ Condition => New_Occurrence_Of (Is_Local, Loc),
Then_Statements => New_List (
- -- if A.Target = null then
+ -- 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)),
+ 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);
+ -- 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)),
+ 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),
+ Name => New_Occurrence_Of (RTE (RE_Entity_Of), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Subp_Ref, Loc)))),
- -- Inc_Usage (A.Target);
+ -- Inc_Usage (A.Target);
+ -- end if;
Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of (RTE (RE_Inc_Usage), 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)))))),
+ 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;
+ -- 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)),
+ Right_Opnd =>
+ 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))))))));
+ Make_Simple_Return_Statement (Loc,
+ Expression =>
+ Unchecked_Convert_To
+ (Fat_Type, New_Occurrence_Of (Local_Addr, Loc))))))));
Append_List_To (Proc_Statements, New_List (
- -- Stub.Target := Entity_Of (Ref);
+ -- Stub.Target := Entity_Of (Ref);
Set_Field (Name_Target,
Make_Function_Call (Loc,
- Name =>
- New_Occurrence_Of (RTE (RE_Entity_Of), Loc),
+ Name => New_Occurrence_Of (RTE (RE_Entity_Of), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Subp_Ref, Loc)))),
- -- Inc_Usage (Stub.Target);
+ -- Inc_Usage (Stub.Target);
Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of (RTE (RE_Inc_Usage), 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.
+ -- 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.
+ -- 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)))));
+ Left_Opnd => New_Occurrence_Of (Asynch_P, Loc),
+ Right_Opnd =>
+ New_Occurrence_Of
+ (Boolean_Literals (Is_Asynchronous (Ras_Type)), Loc)))));
Append_List_To (Proc_Statements,
- Build_Get_Unique_RP_Call (Loc,
- Stub_Ptr, Stub_Elements.Stub_Type));
+ Build_Get_Unique_RP_Call (Loc, Stub_Ptr, Stub_Elements.Stub_Type));
Append_To (Proc_Statements,
- Make_Return_Statement (Loc,
+ Make_Simple_Return_Statement (Loc,
Expression =>
Unchecked_Convert_To (Fat_Type,
New_Occurrence_Of (Stub_Ptr, Loc))));
Parameter_Type =>
New_Occurrence_Of (Standard_Boolean, Loc))),
- Subtype_Mark =>
+ Result_Definition =>
New_Occurrence_Of (Fat_Type, Loc));
-- Set the kind and return type of the function to prevent
begin
Statements := New_List (
- Make_Return_Statement (Loc,
+ Make_Simple_Return_Statement (Loc,
Expression =>
Make_Aggregate (Loc,
Component_Associations => New_List (
Make_Component_Association (Loc,
- Choices => New_List (
- Make_Identifier (Loc, Name_Ras)),
+ Choices => New_List (Make_Identifier (Loc, Name_Ras)),
Expression =>
PolyORB_Support.Helpers.Build_From_Any_Call (
Underlying_RACW_Type (RAS_Type),
Func_Spec :=
Make_Function_Specification (Loc,
- Defining_Unit_Name =>
- Fnam,
+ 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))),
- Subtype_Mark => New_Occurrence_Of (RAS_Type, 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,
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'));
+ Any : constant Entity_Id := Make_Temporary (Loc, 'A');
+ RAS_Parameter : constant Entity_Id := Make_Temporary (Loc, 'R');
RACW_Parameter : constant Node_Id :=
Make_Selected_Component (Loc,
Prefix => RAS_Parameter,
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 =>
+ 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),
+ 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)));
+
+ Make_Simple_Return_Statement (Loc,
+ Expression => New_Occurrence_Of (Any, Loc)));
Func_Spec :=
Make_Function_Specification (Loc,
- Defining_Unit_Name =>
- Fnam,
+ Defining_Unit_Name => Fnam,
Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- RAS_Parameter,
- Parameter_Type =>
- New_Occurrence_Of (RAS_Type, Loc))),
- Subtype_Mark => New_Occurrence_Of (RTE (RE_Any), 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,
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;
-
- RAS_Parameter : constant Entity_Id :=
- Make_Defining_Identifier (Loc, Name_R);
+ Func_Spec : Node_Id;
+ Decls : constant List_Id := New_List;
+ Name_String : String_Id;
+ Repo_Id_String : String_Id;
begin
- -- The spec for this subprogram has a dummy 'access RAS'
- -- argument, which serves only for overloading purposes.
-
Func_Spec :=
Make_Function_Specification (Loc,
- Defining_Unit_Name =>
- Fnam,
- Parameter_Specifications => New_List (
- Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- RAS_Parameter,
- Parameter_Type =>
- Make_Access_Definition (Loc,
- Subtype_Mark => New_Occurrence_Of (RAS_Type, Loc)))),
- Subtype_Mark => New_Occurrence_Of (RTE (RE_TypeCode), 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);
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (
- Make_Return_Statement (Loc,
+ Make_Simple_Return_Statement (Loc,
Expression =>
Make_Function_Call (Loc,
- Name =>
- New_Occurrence_Of (RTE (RE_TC_Build), 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),
+ Name =>
+ New_Occurrence_Of
+ (RTE (RE_TA_Std_String), Loc),
Parameter_Associations => New_List (
Make_String_Literal (Loc, Name_String))),
Make_Function_Call (Loc,
- Name => New_Occurrence_Of (
- RTE (RE_TA_String), Loc),
+ Name =>
+ New_Occurrence_Of
+ (RTE (RE_TA_Std_String), Loc),
Parameter_Associations => New_List (
Make_String_Literal (Loc,
- Repo_Id_String))))))))))));
+ Strval => Repo_Id_String))))))))))));
Set_TSS (RAS_Type, Fnam);
end Add_RAS_TypeCode;
procedure Add_Receiving_Stubs_To_Declarations
(Pkg_Spec : Node_Id;
- Decls : List_Id)
+ Decls : List_Id;
+ Stmts : List_Id)
is
Loc : constant Source_Ptr := Sloc (Pkg_Spec);
Pkg_RPC_Receiver : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- New_Internal_Name ('H'));
+ Make_Temporary (Loc, 'H');
Pkg_RPC_Receiver_Object : Node_Id;
-
Pkg_RPC_Receiver_Body : Node_Id;
Pkg_RPC_Receiver_Decls : List_Id;
Pkg_RPC_Receiver_Statements : List_Id;
- Pkg_RPC_Receiver_Cases : constant List_Id := New_List;
+
+ Pkg_RPC_Receiver_Cases : constant List_Id := New_List;
-- A Pkg_RPC_Receiver is built to decode the request
- Request : Node_Id;
+ Request : Node_Id;
-- Request object received from neutral layer
Subp_Id : Entity_Id;
- -- Subprogram identifier as received from the neutral
- -- distribution core.
+ -- 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).
+ -- 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.
+ Is_Local : constant Entity_Id := Make_Temporary (Loc, 'L');
+
+ Local_Address : constant Entity_Id := Make_Temporary (Loc, 'A');
+ -- Address of a local subprogram designated by a reference
+ -- corresponding to a RAS.
Dispatch_On_Address : constant List_Id := New_List;
Dispatch_On_Name : constant List_Id := New_List;
- Current_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'));
+ Current_Subp_Number : Int := First_RCI_Subprogram_Id;
- Subp_Info_List : constant List_Id := New_List;
+ Subp_Info_Array : constant Entity_Id := Make_Temporary (Loc, 'I');
+ Subp_Info_List : constant List_Id := New_List;
Register_Pkg_Actuals : constant List_Id := New_List;
-- object, used in the context of calls through remote
-- access-to-subprogram types.
+ procedure Visit_Subprogram (Decl : Node_Id);
+ -- Generate receiving stub for one remote subprogram
+
---------------------
-- Append_Stubs_To --
---------------------
Defining_Entity (Stubs), Loc),
Parameter_Associations =>
New_List (New_Occurrence_Of (Request, Loc))));
- if Nkind (Specification (Declaration))
- = N_Function_Specification
+
+ 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));
+ Append_To (Case_Stmts, Make_Simple_Return_Statement (Loc));
end if;
Append_To (RPC_Receiver_Cases,
Make_Case_Statement_Alternative (Loc,
Discrete_Choices =>
New_List (Make_Integer_Literal (Loc, Subp_Number)),
- Statements =>
- Case_Stmts));
+ Statements => Case_Stmts));
Append_To (Dispatch_On_Name,
Make_Elsif_Part (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)))));
+ 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)),
+ 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)))));
+ Make_Integer_Literal (Loc, Subp_Number)))));
end Append_Stubs_To;
+ ----------------------
+ -- Visit_Subprogram --
+ ----------------------
+
+ procedure Visit_Subprogram (Decl : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (Decl);
+ Spec : constant Node_Id := Specification (Decl);
+ Subp_Def : constant Entity_Id := Defining_Unit_Name (Spec);
+
+ Subp_Val : String_Id;
+
+ Subp_Dist_Name : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars =>
+ New_External_Name
+ (Related_Id => Chars (Subp_Def),
+ Suffix => 'D',
+ Suffix_Index => -1));
+
+ Current_Stubs : Node_Id;
+ Proxy_Obj_Addr : Entity_Id;
+
+ begin
+ -- Build receiving stub
+
+ Current_Stubs :=
+ Build_Subprogram_Receiving_Stubs
+ (Vis_Decl => Decl,
+ Asynchronous => Nkind (Spec) = N_Procedure_Specification
+ and then Is_Asynchronous (Subp_Def));
+
+ Append_To (Decls, Current_Stubs);
+ Analyze (Current_Stubs);
+
+ -- Build RAS proxy
+
+ Add_RAS_Proxy_And_Analyze (Decls,
+ Vis_Decl => Decl,
+ All_Calls_Remote_E => All_Calls_Remote_E,
+ Proxy_Object_Addr => Proxy_Obj_Addr);
+
+ -- Compute distribution identifier
+
+ Assign_Subprogram_Identifier
+ (Subp_Def, Current_Subp_Number, Subp_Val);
+
+ pragma Assert
+ (Current_Subp_Number = Get_Subprogram_Id (Subp_Def));
+
+ Append_To (Decls,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Subp_Dist_Name,
+ Constant_Present => True,
+ Object_Definition =>
+ New_Occurrence_Of (Standard_String, Loc),
+ Expression =>
+ Make_String_Literal (Loc, Subp_Val)));
+ Analyze (Last (Decls));
+
+ -- Add subprogram descriptor (RCI_Subp_Info) to the subprograms
+ -- table for this receiver. The aggregate below must be kept
+ -- consistent with the declaration of RCI_Subp_Info in
+ -- System.Partition_Interface.
+
+ Append_To (Subp_Info_List,
+ Make_Component_Association (Loc,
+ Choices =>
+ New_List (Make_Integer_Literal (Loc, Current_Subp_Number)),
+
+ Expression =>
+ Make_Aggregate (Loc,
+ Expressions => New_List (
+
+ -- Name =>
+
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Subp_Dist_Name, Loc),
+ Attribute_Name => Name_Address),
+
+ -- Name_Length =>
+
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Subp_Dist_Name, Loc),
+ Attribute_Name => Name_Length),
+
+ -- Addr =>
+
+ New_Occurrence_Of (Proxy_Obj_Addr, Loc)))));
+
+ Append_Stubs_To (Pkg_RPC_Receiver_Cases,
+ Declaration => Decl,
+ Stubs => Current_Stubs,
+ Subp_Number => Current_Subp_Number,
+ Subp_Dist_Name => Subp_Dist_Name,
+ Subp_Proxy_Addr => Proxy_Obj_Addr);
+
+ Current_Subp_Number := Current_Subp_Number + 1;
+ end Visit_Subprogram;
+
+ procedure Visit_Spec is new Build_Package_Stubs (Visit_Subprogram);
+
-- Start of processing for Add_Receiving_Stubs_To_Declarations
begin
-- Building receiving stubs consist in several operations:
- -- - a package RPC receiver must be built. This subprogram
- -- will get a Subprogram_Id from the incoming stream
- -- and will dispatch the call to the right subprogram
+ -- - a 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
+ -- - a receiving stub for each subprogram visible in the package
-- spec. This stub will read all the parameters from the stream,
-- and put the result as well as the exception occurrence in the
- -- output stream
-
- -- - a dummy package with an empty spec and a body made of an
- -- elaboration part, whose job is to register the receiving
- -- part of this RCI package on the name server. This is done
- -- by calling System.Partition_Interface.Register_Receiving_Stub
+ -- output stream;
Build_RPC_Receiver_Body (
RPC_Receiver => Pkg_RPC_Receiver,
Append_To (Pkg_RPC_Receiver_Decls,
Make_Object_Declaration (Loc,
- Defining_Identifier =>
- Is_Local,
+ 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,
+ 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),
+ Name => New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc),
Parameter_Associations => New_List (
Make_Selected_Component (Loc,
Prefix => Request,
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));
+ -- 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.
- -- Build receiving stub
+ All_Calls_Remote_E := Boolean_Literals (
+ Has_All_Calls_Remote (Defining_Entity (Pkg_Spec)));
- Current_Stubs :=
- Build_Subprogram_Receiving_Stubs
- (Vis_Decl => Current_Declaration,
- Asynchronous =>
- Nkind (Specification (Current_Declaration)) =
- N_Procedure_Specification
- and then Is_Asynchronous (Subp_Def));
+ Overload_Counter_Table.Reset;
+ Reserve_NamingContext_Methods;
- Append_To (Decls, Current_Stubs);
- Analyze (Current_Stubs);
+ Visit_Spec (Pkg_Spec);
- -- Build RAS proxy
+ Append_To (Decls,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Subp_Info_Array,
+ Constant_Present => True,
+ Aliased_Present => True,
+ Object_Definition =>
+ Make_Subtype_Indication (Loc,
+ Subtype_Mark =>
+ New_Occurrence_Of (RTE (RE_RCI_Subp_Info_Array), Loc),
+ Constraint =>
+ Make_Index_Or_Discriminant_Constraint (Loc,
+ New_List (
+ Make_Range (Loc,
+ Low_Bound =>
+ Make_Integer_Literal (Loc,
+ Intval => First_RCI_Subprogram_Id),
+ High_Bound =>
+ Make_Integer_Literal (Loc,
+ Intval =>
+ First_RCI_Subprogram_Id
+ + List_Length (Subp_Info_List) - 1)))))));
+
+ if Present (First (Subp_Info_List)) then
+ Set_Expression (Last (Decls),
+ Make_Aggregate (Loc,
+ Component_Associations => Subp_Info_List));
+
+ -- Generate the dispatch statement to determine the subprogram id
+ -- of the called subprogram.
+
+ -- We first test whether the reference that was used to make the
+ -- call was the base RCI reference (in which case Local_Address is
+ -- zero, and the method identifier from the request must be used
+ -- to determine which subprogram is called) or a reference
+ -- identifying one particular subprogram (in which case
+ -- Local_Address is the address of that subprogram, and the
+ -- method name from the request is ignored). The latter occurs
+ -- for the case of a call through a remote access-to-subprogram.
+
+ -- In each case, cascaded elsifs are used to determine the proper
+ -- subprogram index. Using hash tables might be more efficient.
+
+ Append_To (Pkg_RPC_Receiver_Statements,
+ Make_Implicit_If_Statement (Pkg_Spec,
+ Condition =>
+ Make_Op_Ne (Loc,
+ Left_Opnd => New_Occurrence_Of (Local_Address, Loc),
+ Right_Opnd => New_Occurrence_Of
+ (RTE (RE_Null_Address), Loc)),
- Add_RAS_Proxy_And_Analyze (Decls,
- Vis_Decl =>
- Current_Declaration,
- All_Calls_Remote_E =>
- All_Calls_Remote_E,
- Proxy_Object_Addr =>
- Proxy_Object_Addr);
+ 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))));
- -- Compute distribution identifier
+ else
+ -- For a degenerate RCI with no visible subprograms,
+ -- Subp_Info_List has zero length, and the declaration is for an
+ -- empty array, in which case no initialization aggregate must be
+ -- generated. We do not generate a Dispatch_Statement either.
- Assign_Subprogram_Identifier (
- Subp_Def,
- Current_Subprogram_Number,
- Subp_Val);
+ -- No initialization provided: remove CONSTANT so that the
+ -- declaration is not an incomplete deferred constant.
- 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;
+ Set_Constant_Present (Last (Decls), False);
+ end if;
- Current_Subprogram_Number := Current_Subprogram_Number + 1;
- end if;
+ -- Analyze Subp_Info_Array declaration
- Next (Current_Declaration);
- end loop;
+ Analyze (Last (Decls));
-- If we receive an invalid Subprogram_Id, it is best to do nothing
-- rather than raising an exception since we do not want someone
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))));
+ 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),
+ 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));
+ -- Pkg_RPC_Receiver body is now complete: insert it into the tree and
+ -- analyze it.
Append_To (Decls, Pkg_RPC_Receiver_Body);
Analyze (Last (Decls));
Pkg_RPC_Receiver_Object :=
Make_Object_Declaration (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, New_Internal_Name ('R')),
+ Defining_Identifier => Make_Temporary (Loc, 'R'),
Aliased_Present => True,
- Object_Definition =>
- New_Occurrence_Of (RTE (RE_Servant), Loc));
+ Object_Definition => New_Occurrence_Of (RTE (RE_Servant), Loc));
Append_To (Decls, Pkg_RPC_Receiver_Object);
Analyze (Last (Decls));
Get_Library_Unit_Name_String (Pkg_Spec);
+
+ -- Name
+
Append_To (Register_Pkg_Actuals,
- -- Name
Make_String_Literal (Loc,
Strval => String_From_Name_Buffer));
+ -- Version
+
Append_To (Register_Pkg_Actuals,
- -- Version
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of
(Defining_Entity (Pkg_Spec), Loc),
- Attribute_Name =>
- Name_Version));
+ Attribute_Name => Name_Version));
+
+ -- Handler
Append_To (Register_Pkg_Actuals,
- -- Handler
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Pkg_RPC_Receiver, Loc),
Attribute_Name => Name_Access));
+ -- Receiver
+
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));
+ Defining_Identifier (Pkg_RPC_Receiver_Object), Loc),
+ Attribute_Name => Name_Access));
+
+ -- Subp_Info
Append_To (Register_Pkg_Actuals,
- -- Subp_Info
Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (Subp_Info_Array, Loc),
- Attribute_Name =>
- Name_Address));
+ Prefix => New_Occurrence_Of (Subp_Info_Array, Loc),
+ Attribute_Name => Name_Address));
+
+ -- Subp_Info_Len
Append_To (Register_Pkg_Actuals,
- -- Subp_Info_Len
Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (Subp_Info_Array, Loc),
- Attribute_Name =>
- Name_Length));
+ Prefix => New_Occurrence_Of (Subp_Info_Array, Loc),
+ Attribute_Name => Name_Length));
+
+ -- Is_All_Calls_Remote
Append_To (Register_Pkg_Actuals,
- -- Is_All_Calls_Remote
New_Occurrence_Of (All_Calls_Remote_E, Loc));
- Append_To (Decls,
+ -- Finally call Register_Pkg_Receiving_Stub with the above parameters
+
+ Append_To (Stmts,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Register_Pkg_Receiving_Stub), Loc),
Parameter_Associations => Register_Pkg_Actuals));
- Analyze (Last (Decls));
-
+ Analyze (Last (Stmts));
end Add_Receiving_Stubs_To_Declarations;
---------------------------------
is
Loc : constant Source_Ptr := Sloc (Nod);
+ Request : constant Entity_Id := Make_Temporary (Loc, 'R');
+ -- The request object constructed by these stubs
+ -- Could we use Name_R instead??? (see GLADE client stubs)
+
+ function Make_Request_RTE_Call
+ (RE : RE_Id;
+ Actuals : List_Id := New_List) return Node_Id;
+ -- Generate a procedure call statement calling RE with the given
+ -- actuals. Request'Access is appended to the list.
+
+ ---------------------------
+ -- Make_Request_RTE_Call --
+ ---------------------------
+
+ function Make_Request_RTE_Call
+ (RE : RE_Id;
+ Actuals : List_Id := New_List) return Node_Id
+ is
+ begin
+ Append_To (Actuals,
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Request, Loc),
+ Attribute_Name => Name_Access));
+ return Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Occurrence_Of (RTE (RE), Loc),
+ Parameter_Associations => Actuals);
+ end Make_Request_RTE_Call;
+
Arguments : Node_Id;
-- Name of the named values list used to transmit parameters
-- to the remote package
- 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.
-- 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).
+ -- 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.
+ -- Controlling formal parameters of distributed object primitives
+ -- require special handling, and the first such parameter needs even
+ -- more special handling.
begin
-- ??? document general form of stub subprograms for the PolyORB case
- Request :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => Request,
- Aliased_Present => False,
+ Aliased_Present => True,
Object_Definition =>
- New_Occurrence_Of (RTE (RE_Request_Access), Loc)));
+ New_Occurrence_Of (RTE (RE_Request), Loc)));
- Result :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
+ Result := Make_Temporary (Loc, 'R');
if Is_Function then
- Result_TC := PolyORB_Support.Helpers.Build_TypeCode_Call (Loc,
- Etype (Subtype_Mark (Spec)), Decls);
+ 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;
Make_Aggregate (Loc,
Component_Associations => New_List (
Make_Component_Association (Loc,
- Choices => New_List (
- Make_Identifier (Loc, Name_Name)),
+ Choices => New_List (Make_Identifier (Loc, Name_Name)),
Expression =>
New_Occurrence_Of (RTE (RE_Result_Name), Loc)),
Make_Component_Association (Loc,
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))),
+ Name => New_Occurrence_Of (RTE (RE_Create_Any), Loc),
+ Parameter_Associations => New_List (Result_TC))),
Make_Component_Association (Loc,
- Choices => New_List (
+ Choices => New_List (
Make_Identifier (Loc, Name_Arg_Modes)),
- Expression =>
- Make_Integer_Literal (Loc, 0))))));
+ Expression => Make_Integer_Literal (Loc, 0))))));
if not Is_Known_Asynchronous then
- Exception_Return_Parameter :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
+ Exception_Return_Parameter := Make_Temporary (Loc, 'E');
Append_To (Decls,
Make_Object_Declaration (Loc,
-- Initialize and fill in arguments list
- Arguments :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
+ Arguments := Make_Temporary (Loc, 'A');
Declare_Create_NVList (Loc, Arguments, Decls, Statements);
Current_Parameter := First (Ordered_Parameters_List);
while Present (Current_Parameter) loop
-
if Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type) then
Is_Controlling_Formal := True;
Is_First_Controlling_Formal :=
not First_Controlling_Formal_Seen;
First_Controlling_Formal_Seen := True;
+
else
Is_Controlling_Formal := False;
Is_First_Controlling_Formal := False;
if Is_Controlling_Formal then
- -- In the case of a controlling formal argument, we send
- -- its reference.
+ -- For a controlling formal argument, we send its reference
Etyp := RACW_Type;
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.
+ -- 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'));
+ Any : constant Entity_Id := Make_Temporary (Loc, 'A');
Actual_Parameter : Node_Id :=
New_Occurrence_Of (
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.
+ -- 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
else
Actual_Parameter := OK_Convert_To (Etyp,
Make_Attribute_Reference (Loc,
- Prefix =>
- Actual_Parameter,
- Attribute_Name =>
- Name_Unrestricted_Access));
+ Prefix => Actual_Parameter,
+ Attribute_Name => Name_Unrestricted_Access));
end if;
end if;
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.
+ -- 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);
- 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),
+ Name => New_Occurrence_Of (RTE (RE_Create_Any), Loc),
Parameter_Associations => New_List (
- PolyORB_Support.Helpers.Build_TypeCode_Call (Loc,
- Etyp, Decls)));
+ PolyORB_Support.Helpers.Build_TypeCode_Call
+ (Loc, Etyp, Decls)));
end if;
Append_To (Decls,
Make_Object_Declaration (Loc,
- Defining_Identifier =>
- Any,
+ Defining_Identifier => Any,
Aliased_Present => False,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Any), Loc),
- Expression =>
- Expr));
+ Expression => Expr));
Append_To (Statements,
Add_Parameter_To_NVList (Loc,
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)));
-
+ if Is_Limited_Type (Etyp) then
+ Helpers.Assign_Opaque_From_Any (Loc,
+ Stms => After_Statements,
+ Typ => Etyp,
+ N => New_Occurrence_Of (Any, Loc),
+ Target =>
+ Defining_Identifier (Current_Parameter));
+ else
+ Append_To (After_Statements,
+ Make_Assignment_Statement (Loc,
+ Name =>
+ New_Occurrence_Of (
+ Defining_Identifier (Current_Parameter), Loc),
+ Expression =>
+ PolyORB_Support.Helpers.Build_From_Any_Call
+ (Etyp,
+ New_Occurrence_Of (Any, Loc),
+ Decls)));
+ end if;
end if;
end;
end if;
- -- If the current parameter has a dynamic constrained status,
- -- then this status is transmitted as well.
+ -- 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
+ 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
declare
Extra_Any_Parameter : constant Entity_Id :=
- Make_Defining_Identifier
- (Loc, New_Internal_Name ('P'));
+ Make_Temporary (Loc, 'P');
+
+ Parameter_Exp : constant Node_Id :=
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (
+ Defining_Identifier (Current_Parameter), Loc),
+ Attribute_Name => Name_Constrained);
begin
+ Set_Etype (Parameter_Exp, Etype (Standard_Boolean));
+
Append_To (Decls,
Make_Object_Declaration (Loc,
- Defining_Identifier =>
- Extra_Any_Parameter,
+ 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)));
+ PolyORB_Support.Helpers.Build_To_Any_Call
+ (Parameter_Exp, Decls)));
+
Append_To (Extra_Formal_Statements,
Add_Parameter_To_NVList (Loc,
Parameter => Extra_Any_Parameter,
Append_To (Statements,
Make_Procedure_Call_Statement (Loc,
Name =>
- New_Occurrence_Of (RTE (RE_Request_Create), Loc),
+ New_Occurrence_Of (RTE (RE_Request_Setup), Loc),
Parameter_Associations => New_List (
+ New_Occurrence_Of (Request, Loc),
Target_Object,
Subprogram_Id,
New_Occurrence_Of (Arguments, Loc),
New_Occurrence_Of (Result, Loc),
New_Occurrence_Of (RTE (RE_Nil_Exc_List), Loc))));
- Append_To (Parameter_Associations (Last (Statements)),
- New_Occurrence_Of (Request, Loc));
+ pragma Assert
+ (not (Is_Known_Non_Asynchronous and Is_Known_Asynchronous));
- 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);
+ 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.
+
+ -- 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)),
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))));
+ Append_To (Statements, Make_Request_RTE_Call (RE_Request_Invoke));
- Non_Asynchronous_Statements := New_List (Make_Null_Statement (Loc));
- Asynchronous_Statements := New_List (Make_Null_Statement (Loc));
+ -- Asynchronous case
- if not Is_Known_Asynchronous then
+ if not Is_Known_Non_Asynchronous then
+ Asynchronous_Statements := New_List (Make_Null_Statement (Loc));
+ end if;
+
+ -- Non-asynchronous case
+ if not Is_Known_Asynchronous then
-- Reraise an exception occurrence from the completed request.
-- If the exception occurrence is empty, this is a no-op.
- Append_To (Non_Asynchronous_Statements,
+ Non_Asynchronous_Statements := New_List (
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Request_Raise_Occurrence), Loc),
New_Occurrence_Of (Request, Loc))));
if Is_Function then
-
- -- If this is a function call, then read the value and
- -- return it.
+ -- If this is a function call, 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 (Subtype_Mark (Spec)),
- Make_Selected_Component (Loc,
- Prefix => Result,
- Selector_Name => Name_Argument),
- Decls))));
+ Make_Simple_Return_Statement (Loc,
+ PolyORB_Support.Helpers.Build_From_Any_Call
+ (Etype (Result_Definition (Spec)),
+ Make_Selected_Component (Loc,
+ Prefix => Result,
+ Selector_Name => Name_Argument),
+ Decls))));
+
+ else
+
+ -- Case of a procedure: deal with IN OUT and OUT formals
+
+ Append_List_To (Non_Asynchronous_Statements, After_Statements);
end if;
end if;
- Append_List_To (Non_Asynchronous_Statements,
- After_Statements);
-
if Is_Known_Asynchronous then
Append_List_To (Statements, Asynchronous_Statements);
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'));
+ Target_Reference : constant Entity_Id := Make_Temporary (Loc, 'T');
+
begin
if Present (Controlling_Parameter) then
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => Target_Reference,
+
Object_Definition =>
New_Occurrence_Of (RTE (RE_Object_Ref), Loc),
+
Expression =>
Make_Function_Call (Loc,
Name =>
Make_Selected_Component (Loc,
Prefix => Controlling_Parameter,
Selector_Name => Name_Target)))));
- -- Controlling_Parameter has the same components
- -- as System.Partition_Interface.RACW_Stub_Type.
+
+ -- Note: Controlling_Parameter has the same components as
+ -- System.Partition_Interface.RACW_Stub_Type.
Target_Info.Object := New_Occurrence_Of (Target_Reference, Loc);
Selector_Name =>
Make_Identifier (Loc, Name_Get_RCI_Package_Ref));
end if;
+
return Target_Info;
end Build_Stub_Target;
procedure Build_Stub_Type
(RACW_Type : Entity_Id;
- Stub_Type : Entity_Id;
- Stub_Type_Decl : out Node_Id;
+ Stub_Type_Comps : out List_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);
+ Loc : constant Source_Ptr := Sloc (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_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)))))));
+ Stub_Type_Comps := 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')),
+ Defining_Identifier => Make_Temporary (Loc, 'R'),
Aliased_Present => True,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Servant), Loc));
Request := Make_Defining_Identifier (Loc, Name_R);
RPC_Receiver_Spec :=
- Build_RPC_Receiver_Specification (
- RPC_Receiver => RPC_Receiver,
- Request_Parameter => Request);
+ 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);
is
Loc : constant Source_Ptr := Sloc (Vis_Decl);
- Request_Parameter : Node_Id;
- -- ???
+ Request_Parameter : constant Entity_Id := Make_Temporary (Loc, 'R');
+ -- Formal parameter for receiving stubs: a descriptor for an incoming
+ -- request.
Outer_Decls : constant List_Id := New_List;
- -- At the outermost level, an NVList and Any's are
- -- declared for all parameters. The Dynamic_Async
- -- flag also needs to be declared there to be visible
- -- from the exception handling code.
+ -- At the outermost level, an NVList and Any's are declared for all
+ -- parameters. The Dynamic_Async flag also needs to be declared there
+ -- to be visible from the exception handling code.
Outer_Statements : constant List_Id := New_List;
-- Statements that occur prior to the declaration of the actual
-- parameter variables.
+ Outer_Extra_Formal_Statements : constant List_Id := New_List;
+ -- Statements concerning extra formal parameters, prior to the
+ -- declaration of the actual parameter variables.
+
Decls : constant List_Id := New_List;
-- All the parameters will get declared before calling the real
- -- subprograms. Also the out parameters will be declared.
- -- At this level, parameters may be unconstrained.
+ -- 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
Build_Ordered_Parameters_List
(Specification (Vis_Decl));
- Arguments : Node_Id;
+ Arguments : constant Entity_Id := Make_Temporary (Loc, 'A');
-- Name of the named values list used to retrieve parameters
Subp_Spec : Node_Id;
New_Occurrence_Of (Parent_Primitive, Loc);
else
Called_Subprogram :=
- New_Occurrence_Of (
- Defining_Unit_Name (Specification (Vis_Decl)), Loc);
+ 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
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;
+ Any : Entity_Id := Empty;
+ Object : constant Entity_Id := Make_Temporary (Loc, 'P');
+ Expr : Node_Id := Empty;
- Is_Controlling_Formal : constant Boolean
- := Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type);
+ Is_Controlling_Formal : constant Boolean :=
+ Is_RACW_Controlling_Formal
+ (Current_Parameter, Stub_Type);
Is_First_Controlling_Formal : Boolean := False;
- begin
- Set_Ekind (Object, E_Variable);
+ Need_Extra_Constrained : Boolean;
+ -- True when an extra constrained actual is required
+
+ begin
if Is_Controlling_Formal then
-- Controlling formals in distributed object primitive
-- operations are handled specially:
+
-- - the first controlling formal is used as the
-- target of the call;
+
-- - the remaining controlling formals are transmitted
-- as RACWs.
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);
+ 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'));
+ Any := Make_Temporary (Loc, 'A');
+
Append_To (Outer_Decls,
Make_Object_Declaration (Loc,
- Defining_Identifier =>
- Any,
+ 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),
+ Name => New_Occurrence_Of (RTE (RE_Create_Any), Loc),
Parameter_Associations => New_List (
- PolyORB_Support.Helpers.Build_TypeCode_Call (Loc,
- Etyp, Outer_Decls)))));
+ PolyORB_Support.Helpers.Build_TypeCode_Call
+ (Loc, Etyp, Outer_Decls)))));
Append_To (Outer_Statements,
Add_Parameter_To_NVList (Loc,
if Is_First_Controlling_Formal then
declare
- Addr : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- New_Internal_Name ('A'));
+ Addr : constant Entity_Id := Make_Temporary (Loc, 'A');
+
Is_Local : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- New_Internal_Name ('L'));
- begin
+ Make_Temporary (Loc, 'L');
- -- Special case: obtain the first controlling
- -- formal from the target of the remote call,
- -- instead of the argument list.
+ 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,
+ Defining_Identifier => Addr,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Address), Loc)));
+
Append_To (Outer_Decls,
Make_Object_Declaration (Loc,
- Defining_Identifier =>
- Is_Local,
+ 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),
+ New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc),
Parameter_Associations => New_List (
Make_Selected_Component (Loc,
- Prefix =>
+ Prefix =>
New_Occurrence_Of (
Request_Parameter, Loc),
Selector_Name =>
or else not Out_Present (Current_Parameter)
or else not Constrained
then
- -- If an input parameter is contrained, then its reading is
+ -- If an input parameter is constrained, then its reading is
-- deferred until the beginning of the subprogram body. If
-- it is unconstrained, then an expression is built for
-- the object declaration and the variable is set using
-- 'Input instead of 'Read.
- Expr := PolyORB_Support.Helpers.Build_From_Any_Call (
- Etyp, New_Occurrence_Of (Any, Loc), Decls);
-
- if Constrained then
+ if Constrained and then Is_Limited_Type (Etyp) then
+ Helpers.Assign_Opaque_From_Any (Loc,
+ Stms => Statements,
+ Typ => Etyp,
+ N => New_Occurrence_Of (Any, Loc),
+ Target => Object);
- Append_To (Statements,
- Make_Assignment_Statement (Loc,
- Name =>
- New_Occurrence_Of (Object, Loc),
- Expression =>
- Expr));
- Expr := Empty;
else
+ Expr := Helpers.Build_From_Any_Call
+ (Etyp, New_Occurrence_Of (Any, Loc), Decls);
+
+ if Constrained then
+ Append_To (Statements,
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Object, Loc),
+ Expression => Expr));
+ Expr := Empty;
+
+ else
+ -- Expr will be used to initialize (and constrain) the
+ -- parameter when it is declared.
+ null;
+ end if;
+
null;
- -- 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));
+ Need_Extra_Constrained :=
+ Nkind (Parameter_Type (Current_Parameter)) /=
+ N_Access_Definition
+ and then
+ Ekind (Defining_Identifier (Current_Parameter)) /= E_Void
+ and then
+ Present (Extra_Constrained
+ (Defining_Identifier (Current_Parameter)));
+
+ -- We may not associate an extra constrained actual to a
+ -- constant object, so if one is needed, declare the actual
+ -- as a variable even if it won't be modified.
+
+ Build_Actual_Object_Declaration
+ (Object => Object,
+ Etyp => Etyp,
+ Variable => Need_Extra_Constrained
+ or else Out_Present (Current_Parameter),
+ Expr => Expr,
+ Decls => Decls);
Set_Etype (Object, Etyp);
-- An out parameter may be written back using a 'Write
then
Append_To (After_Statements,
Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of (RTE (RE_Copy_Any_Value), Loc),
+ Name => New_Occurrence_Of (RTE (RE_Move_Any_Value), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Any, Loc),
- PolyORB_Support.Helpers.Build_To_Any_Call (
- New_Occurrence_Of (Object, Loc),
- Decls))));
+ 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
if Is_Controlling_Formal then
if Nkind (Parameter_Type (Current_Parameter)) /=
- N_Access_Definition
+ N_Access_Definition
then
Append_To (Parameter_List,
Make_Parameter_Association (Loc,
Selector_Name =>
- New_Occurrence_Of (
- Defining_Identifier (Current_Parameter), Loc),
+ 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))))));
+ Prefix => New_Occurrence_Of (Object, Loc))));
else
Append_To (Parameter_List,
Make_Parameter_Association (Loc,
Selector_Name =>
- New_Occurrence_Of (
- Defining_Identifier (Current_Parameter), Loc),
+ 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)))));
+ New_Occurrence_Of (Object, Loc)));
end if;
else
-- 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
+ if Need_Extra_Constrained then
declare
Extra_Parameter : constant Entity_Id :=
Extra_Constrained
(Defining_Identifier
(Current_Parameter));
+
Extra_Any : constant Entity_Id :=
- Make_Defining_Identifier
- (Loc, New_Internal_Name ('A'));
+ Make_Temporary (Loc, 'A');
+
Formal_Entity : constant Entity_Id :=
- Make_Defining_Identifier
- (Loc, Chars (Extra_Parameter));
+ Make_Defining_Identifier (Loc,
+ Chars => Chars (Extra_Parameter));
Formal_Type : constant Entity_Id :=
Etype (Extra_Parameter);
+
begin
Append_To (Outer_Decls,
Make_Object_Declaration (Loc,
- Defining_Identifier =>
- Extra_Any,
+ Defining_Identifier => Extra_Any,
Object_Definition =>
- New_Occurrence_Of (RTE (RE_Any), Loc)));
+ New_Occurrence_Of (RTE (RE_Any), Loc),
+ Expression =>
+ Make_Function_Call (Loc,
+ Name =>
+ New_Occurrence_Of (RTE (RE_Create_Any), Loc),
+ Parameter_Associations => New_List (
+ PolyORB_Support.Helpers.Build_TypeCode_Call
+ (Loc, Formal_Type, Outer_Decls)))));
- Append_To (Outer_Statements,
+ Append_To (Outer_Extra_Formal_Statements,
Add_Parameter_To_NVList (Loc,
Parameter => Extra_Parameter,
NVList => Arguments,
Object_Definition =>
New_Occurrence_Of (Formal_Type, Loc)));
- Append_To (Extra_Formal_Statements,
+ Append_To (Statements,
Make_Assignment_Statement (Loc,
- Name =>
- New_Occurrence_Of (Extra_Parameter, Loc),
+ Name => New_Occurrence_Of (Formal_Entity, Loc),
Expression =>
- PolyORB_Support.Helpers.Build_From_Any_Call (
- Etype (Extra_Parameter),
- New_Occurrence_Of (Extra_Any, Loc),
- Decls)));
+ PolyORB_Support.Helpers.Build_From_Any_Call
+ (Formal_Type,
+ New_Occurrence_Of (Extra_Any, Loc),
+ Decls)));
Set_Extra_Constrained (Object, Formal_Entity);
-
end;
end if;
end;
Next (Current_Parameter);
end loop;
+ -- Extra Formals should go after all the other parameters
+
+ Append_List_To (Outer_Statements, Outer_Extra_Formal_Statements);
+
Append_To (Outer_Statements,
Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of (RTE (RE_Request_Arguments), Loc),
+ 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.
+ if Nkind (Specification (Vis_Decl)) = N_Function_Specification then
+
+ -- The remote subprogram is a function: Build an inner block to be
+ -- able to hold a potentially unconstrained result in a variable.
declare
Etyp : constant Entity_Id :=
- Etype (Subtype_Mark (Specification (Vis_Decl)));
- Result : constant Node_Id :=
- Make_Defining_Identifier (Loc,
- New_Internal_Name ('R'));
+ Etype (Result_Definition (Specification (Vis_Decl)));
+ Result : constant Node_Id := Make_Temporary (Loc, 'R');
+
begin
Inner_Decls := New_List (
Make_Object_Declaration (Loc,
Name => Called_Subprogram,
Parameter_Associations => Parameter_List)));
+ if Is_Class_Wide_Type (Etyp) then
+
+ -- For a remote call to a function with a class-wide type,
+ -- check that the returned value satisfies the requirements
+ -- of (RM E.4(18)).
+
+ Append_To (Inner_Decls,
+ Make_Transportable_Check (Loc,
+ New_Occurrence_Of (Result, Loc)));
+
+ end if;
+
Set_Etype (Result, Etyp);
Append_To (After_Statements,
Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of (RTE (RE_Set_Result), Loc),
+ 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))));
+ 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 (After_Statements,
Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of (RTE (RE_Request_Set_Out), Loc),
+ Name => New_Occurrence_Of (RTE (RE_Request_Set_Out), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Request_Parameter, Loc))));
Subp_Spec :=
Make_Procedure_Specification (Loc,
- Defining_Unit_Name =>
- Make_Defining_Identifier (Loc, New_Internal_Name ('F')),
+ Defining_Unit_Name => Make_Temporary (Loc, 'F'),
Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc,
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).
+ -- 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,
+ Make_Implicit_Exception_Handler (Loc,
Exception_Choices => New_List (Make_Others_Choice (Loc)),
Statements => New_List (Make_Null_Statement (Loc))));
else
-
-- In the other cases, if an exception is raised, then the
-- exception occurrence is propagated.
Append_To (Outer_Statements,
Make_Block_Statement (Loc,
- Declarations =>
- Decls,
+ Declarations => Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Statements)));
Statements => Outer_Statements,
Exception_Handlers => Excep_Handlers));
end Build_Subprogram_Receiving_Stubs;
+
-------------
-- Helpers --
-------------
function Find_Numeric_Representation
(Typ : Entity_Id) return Entity_Id;
- -- Given a numeric type Typ, return the smallest integer or floarting
+ -- Given a numeric type Typ, return the smallest integer or floating
-- point type from Standard, or the smallest unsigned (modular) type
-- from System.Unsigned_Types, whose range encompasses that of Typ.
- function Make_Stream_Procedure_Function_Name
+ function Make_Helper_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???)
+ -- Return the name to be assigned for helper subprogram Nam of Typ
------------------------------------------------------------
-- Common subprograms for building various tree fragments --
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.
+ -- Build a call to Get_Aggregate_Element on Any for typecode TC,
+ -- returning the Idx'th element.
generic
Subprogram : Entity_Id;
Arry : Entity_Id;
-- For 'Range and Etype
- Indices : List_Id;
+ Indexes : List_Id;
-- For the construction of the innermost element expression
with procedure Add_Process_Element
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
+ -- executed for each element; Indexes is the list of indexes to be
-- used in the construction of the indexed component that denotes the
-- current element. Subprogram is the entity for the subprogram for
-- which this iterator is generated. The generated statements are
Container : Node_Or_Entity_Id;
Counter : in out Int)
is
- CI : constant List_Id := Component_Items (Clist);
- VP : constant Node_Id := Variant_Part (Clist);
+ CI : List_Id;
+ VP : Node_Id;
+ -- Clist's Component_Items and Variant_Part
- Item : Node_Id := First (CI);
+ Item : Node_Id;
Def : Entity_Id;
begin
+ if No (Clist) then
+ return;
+ end if;
+
+ CI := Component_Items (Clist);
+ VP := Variant_Part (Clist);
+
+ Item := First (CI);
while Present (Item) loop
Def := Defining_Identifier (Item);
+
if not Is_Internal_Name (Chars (Def)) then
Add_Process_Element
(Stmts, Container, Counter, Rec, Def);
end if;
+
Next (Item);
end loop;
end if;
end Append_Record_Traversal;
+ -----------------------------
+ -- Assign_Opaque_From_Any --
+ -----------------------------
+
+ procedure Assign_Opaque_From_Any
+ (Loc : Source_Ptr;
+ Stms : List_Id;
+ Typ : Entity_Id;
+ N : Node_Id;
+ Target : Entity_Id)
+ is
+ Strm : constant Entity_Id := Make_Temporary (Loc, 'S');
+ Expr : Node_Id;
+
+ Read_Call_List : List_Id;
+ -- List on which to place the 'Read attribute reference
+
+ begin
+ -- Strm : Buffer_Stream_Type;
+
+ Append_To (Stms,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Strm,
+ Aliased_Present => True,
+ Object_Definition =>
+ New_Occurrence_Of (RTE (RE_Buffer_Stream_Type), Loc)));
+
+ -- Any_To_BS (Strm, A);
+
+ Append_To (Stms,
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Occurrence_Of (RTE (RE_Any_To_BS), Loc),
+ Parameter_Associations => New_List (
+ N,
+ New_Occurrence_Of (Strm, Loc))));
+
+ if Transmit_As_Unconstrained (Typ) then
+ Expr :=
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Typ, Loc),
+ Attribute_Name => Name_Input,
+ Expressions => New_List (
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Strm, Loc),
+ Attribute_Name => Name_Access)));
+
+ -- Target := Typ'Input (Strm'Access)
+
+ if Present (Target) then
+ Append_To (Stms,
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Target, Loc),
+ Expression => Expr));
+
+ -- return Typ'Input (Strm'Access);
+
+ else
+ Append_To (Stms,
+ Make_Simple_Return_Statement (Loc,
+ Expression => Expr));
+ end if;
+
+ else
+ if Present (Target) then
+ Read_Call_List := Stms;
+ Expr := New_Occurrence_Of (Target, Loc);
+
+ else
+ declare
+ Temp : constant Entity_Id := Make_Temporary (Loc, 'R');
+
+ begin
+ Read_Call_List := New_List;
+ Expr := New_Occurrence_Of (Temp, Loc);
+
+ Append_To (Stms, Make_Block_Statement (Loc,
+ Declarations => New_List (
+ Make_Object_Declaration (Loc,
+ Defining_Identifier =>
+ Temp,
+ Object_Definition =>
+ New_Occurrence_Of (Typ, Loc))),
+
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => Read_Call_List)));
+ end;
+ end if;
+
+ -- Typ'Read (Strm'Access, [Target|Temp])
+
+ Append_To (Read_Call_List,
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Typ, Loc),
+ Attribute_Name => Name_Read,
+ Expressions => New_List (
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Strm, Loc),
+ Attribute_Name => Name_Access),
+ Expr)));
+
+ if No (Target) then
+
+ -- return Temp
+
+ Append_To (Read_Call_List,
+ Make_Simple_Return_Statement (Loc,
+ Expression => New_Copy (Expr)));
+ end if;
+ end if;
+ end Assign_Opaque_From_Any;
+
-------------------------
-- Build_From_Any_Call --
-------------------------
Fnam : Entity_Id := Empty;
Lib_RE : RE_Id := RE_Null;
+ Result : Node_Id;
begin
-
-- First simple case where the From_Any function is present
-- in the type's TSS.
Fnam := Find_Inherited_TSS (U_Type, TSS_From_Any);
+ -- For the subtype representing a generic actual type, go to the
+ -- actual type.
+
+ if Is_Generic_Actual_Type (U_Type) then
+ U_Type := Underlying_Type (Base_Type (U_Type));
+ end if;
+
+ -- For a standard subtype, go to the base type
+
if Sloc (U_Type) <= Standard_Location then
U_Type := Base_Type (U_Type);
end if;
elsif U_Type = RTE (RE_Long_Long_Unsigned) then
Lib_RE := RE_FA_LLU;
- elsif U_Type = Standard_String then
+ elsif Is_RTE (U_Type, RE_Unbounded_String) then
Lib_RE := RE_FA_String;
+ -- Special DSA types
+
+ elsif Is_RTE (U_Type, RE_Any_Container_Ptr) then
+ Lib_RE := RE_FA_A;
+
-- Other (non-primitive) types
else
declare
Decl : Entity_Id;
+
begin
Build_From_Any_Function (Loc, U_Type, Decl, Fnam);
Append_To (Decls, Decl);
Fnam := RTE (Lib_RE);
end if;
- return
- Make_Function_Call (Loc,
- Name => New_Occurrence_Of (Fnam, Loc),
- Parameter_Associations => New_List (N));
+ Result :=
+ Make_Function_Call (Loc,
+ Name => New_Occurrence_Of (Fnam, Loc),
+ Parameter_Associations => New_List (N));
+
+ -- We must set the type of Result, so the unchecked conversion
+ -- from the underlying type to the base type is properly done.
+
+ Set_Etype (Result, U_Type);
+
+ return Unchecked_Convert_To (Typ, Result);
end Build_From_Any_Call;
-----------------------------
Decl : out Node_Id;
Fnam : out Entity_Id)
is
- Spec : Node_Id;
+ 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'));
+ Stms : constant List_Id := New_List;
+
+ Any_Parameter : constant Entity_Id := Make_Temporary (Loc, 'A');
+
+ Use_Opaque_Representation : Boolean;
+
begin
- Fnam := Make_Stream_Procedure_Function_Name (Loc,
- Typ, Name_uFrom_Any);
+ -- For a derived type, we can't go past the base type (to the
+ -- parent type) here, because that would cause the attribute's
+ -- formal parameter to have the wrong type; hence the Base_Type
+ -- check here.
+
+ if Is_Itype (Typ) and then Typ /= Base_Type (Typ) then
+ Build_From_Any_Function
+ (Loc => Loc,
+ Typ => Etype (Typ),
+ Decl => Decl,
+ Fnam => Fnam);
+ return;
+ end if;
+
+ Fnam := Make_Helper_Function_Name (Loc, Typ, Name_From_Any);
Spec :=
Make_Function_Specification (Loc,
Defining_Unit_Name => Fnam,
Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- Any_Parameter,
- Parameter_Type =>
- New_Occurrence_Of (RTE (RE_Any), Loc))),
- Subtype_Mark => New_Occurrence_Of (Typ, 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
+ -- The RACW case is taken care of by Exp_Dist.Add_RACW_From_Any
pragma Assert
(not (Is_Remote_Access_To_Class_Wide_Type (Typ)));
- if Is_Derived_Type (Typ)
- and then not Is_Tagged_Type (Typ)
+ Use_Opaque_Representation := False;
+
+ if Has_Stream_Attribute_Definition
+ (Typ, TSS_Stream_Output, At_Any_Place => True)
+ or else
+ Has_Stream_Attribute_Definition
+ (Typ, TSS_Stream_Write, At_Any_Place => True)
then
+ -- If user-defined stream attributes are specified for this
+ -- type, use them and transmit data as an opaque sequence of
+ -- stream elements.
+
+ Use_Opaque_Representation := True;
+
+ elsif Is_Derived_Type (Typ) and then not Is_Tagged_Type (Typ) then
Append_To (Stms,
- Make_Return_Statement (Loc,
+ Make_Simple_Return_Statement (Loc,
Expression =>
- OK_Convert_To (
- Typ,
- Build_From_Any_Call (
- Root_Type (Typ),
- New_Occurrence_Of (Any_Parameter, Loc),
- Decls))));
+ 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)
then
if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then
Append_To (Stms,
- Make_Return_Statement (Loc,
+ Make_Simple_Return_Statement (Loc,
Expression =>
- OK_Convert_To (
- Typ,
- Build_From_Any_Call (
- Etype (Typ),
- New_Occurrence_Of (Any_Parameter, Loc),
- Decls))));
+ Build_From_Any_Call
+ (Etype (Typ),
+ New_Occurrence_Of (Any_Parameter, Loc),
+ Decls)));
+
else
declare
- Disc : Entity_Id := Empty;
+ Disc : Entity_Id := Empty;
Discriminant_Associations : List_Id;
- Rdef : constant Node_Id :=
- Type_Definition (Declaration_Node (Typ));
- Component_Counter : Int := 0;
+ 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 : constant Entity_Id := Make_Temporary (Loc, 'R');
Res_Definition : Node_Id := New_Occurrence_Of (Typ, Loc);
procedure FA_Append_Record_Traversal is
new Append_Record_Traversal
- (Rec => Res,
- Add_Process_Element => FA_Rec_Add_Process_Element);
+ (Rec => Res,
+ Add_Process_Element => FA_Rec_Add_Process_Element);
--------------------------------
-- FA_Rec_Add_Process_Element --
Rec : Entity_Id;
Field : Node_Id)
is
+ Ctyp : Entity_Id;
begin
if Nkind (Field) = N_Defining_Identifier then
-
-- A regular component
+ Ctyp := Etype (Field);
+
Append_To (Stmts,
Make_Assignment_Statement (Loc,
Name => Make_Selected_Component (Loc,
New_Occurrence_Of (Rec, Loc),
Selector_Name =>
New_Occurrence_Of (Field, Loc)),
+
Expression =>
- Build_From_Any_Call (Etype (Field),
+ Build_From_Any_Call (Ctyp,
Build_Get_Aggregate_Element (Loc,
Any => Any,
- Tc => Build_TypeCode_Call (Loc,
- Etype (Field), Decls),
- Idx => Make_Integer_Literal (Loc,
- Counter)),
+ TC =>
+ Build_TypeCode_Call (Loc, Ctyp, Decls),
+ Idx =>
+ Make_Integer_Literal (Loc, Counter)),
Decls)));
else
-- A variant part
declare
- Variant : Node_Id;
+ Variant : Node_Id;
Struct_Counter : Int := 0;
Block_Decls : constant List_Id := New_List;
Choice_List : List_Id;
Struct_Any : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- New_Internal_Name ('S'));
+ Make_Temporary (Loc, 'S');
begin
Append_To (Decls,
Make_Object_Declaration (Loc,
- Defining_Identifier =>
- Struct_Any,
- Constant_Present =>
- True,
- Object_Definition =>
+ Defining_Identifier => Struct_Any,
+ Constant_Present => True,
+ Object_Definition =>
New_Occurrence_Of (RTE (RE_Any), Loc),
- Expression =>
+ Expression =>
Make_Function_Call (Loc,
- Name => New_Occurrence_Of (
- RTE (RE_Extract_Union_Value), Loc),
+ Name =>
+ New_Occurrence_Of
+ (RTE (RE_Extract_Union_Value), Loc),
+
Parameter_Associations => New_List (
Build_Get_Aggregate_Element (Loc,
Any => Any,
- Tc => Make_Function_Call (Loc,
- Name => New_Occurrence_Of (
- RTE (RE_Any_Member_Type), Loc),
- Parameter_Associations =>
- New_List (
- New_Occurrence_Of (Any, Loc),
- Make_Integer_Literal (Loc,
- Counter))),
- Idx => Make_Integer_Literal (Loc,
- Counter))))));
+ TC =>
+ Make_Function_Call (Loc,
+ Name => New_Occurrence_Of (
+ RTE (RE_Any_Member_Type), Loc),
+ Parameter_Associations =>
+ New_List (
+ New_Occurrence_Of (Any, Loc),
+ Make_Integer_Literal (Loc,
+ Intval => Counter))),
+ Idx =>
+ Make_Integer_Literal (Loc,
+ Intval => Counter))))));
Append_To (Stmts,
Make_Block_Statement (Loc,
- Declarations =>
- Block_Decls,
+ Declarations => Block_Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Block_Stmts)));
Expression =>
Make_Selected_Component (Loc,
Prefix => Rec,
- Selector_Name =>
- Chars (Name (Field))),
- Alternatives =>
- Alt_List));
+ 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));
+ Choice_List :=
+ New_Copy_List_Tree
+ (Discrete_Choices (Variant));
VP_Stmts := New_List;
+
+ -- Struct_Counter should be reset before
+ -- handling a variant part. Indeed only one
+ -- of the case statement alternatives will be
+ -- executed at run time, so the counter must
+ -- start at 0 for every case statement.
+
+ Struct_Counter := 0;
+
FA_Append_Record_Traversal (
Stmts => VP_Stmts,
Clist => Component_List (Variant),
Append_To (Alt_List,
Make_Case_Statement_Alternative (Loc,
Discrete_Choices => Choice_List,
- Statements =>
- VP_Stmts));
+ Statements => VP_Stmts));
Next_Non_Pragma (Variant);
end loop;
end;
end if;
+
Counter := Counter + 1;
end FA_Rec_Add_Process_Element;
-- First all discriminants
if Has_Discriminants (Typ) then
- Disc := First_Discriminant (Typ);
Discriminant_Associations := New_List;
+ Disc := First_Discriminant (Typ);
while Present (Disc) loop
declare
Disc_Var_Name : constant Entity_Id :=
- Make_Defining_Identifier (Loc, Chars (Disc));
- Disc_Type : constant Entity_Id :=
- Etype (Disc);
+ Make_Defining_Identifier (Loc,
+ Chars => Chars (Disc));
+ Disc_Type : constant Entity_Id :=
+ Etype (Disc);
+
begin
Append_To (Decls,
Make_Object_Declaration (Loc,
- Defining_Identifier =>
- Disc_Var_Name,
- Constant_Present => True,
- Object_Definition =>
+ Defining_Identifier => Disc_Var_Name,
+ Constant_Present => True,
+ Object_Definition =>
New_Occurrence_Of (Disc_Type, Loc),
+
Expression =>
- Build_From_Any_Call (Etype (Disc),
+ Build_From_Any_Call (Disc_Type,
Build_Get_Aggregate_Element (Loc,
Any => Any_Parameter,
- Tc => Build_TypeCode_Call
- (Loc, Etype (Disc), Decls),
- Idx => Make_Integer_Literal
- (Loc, Component_Counter)),
+ TC => Build_TypeCode_Call
+ (Loc, Disc_Type, Decls),
+ Idx => Make_Integer_Literal (Loc,
+ Intval => Component_Counter)),
Decls)));
+
Component_Counter := Component_Counter + 1;
Append_To (Discriminant_Associations,
Next_Discriminant (Disc);
end loop;
- Res_Definition := Make_Subtype_Indication (Loc,
- Subtype_Mark => Res_Definition,
- Constraint =>
- Make_Index_Or_Discriminant_Constraint (Loc,
- Discriminant_Associations));
+ 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
Append_To (Decls,
Make_Object_Declaration (Loc,
- Defining_Identifier =>
- Res,
- Object_Definition =>
- Res_Definition));
+ Defining_Identifier => Res,
+ Object_Definition => Res_Definition));
-- ... then all components
Counter => Component_Counter);
Append_To (Stms,
- Make_Return_Statement (Loc,
+ Make_Simple_Return_Statement (Loc,
Expression => New_Occurrence_Of (Res, Loc)));
end;
end if;
Name => Datum,
Expression => Empty);
- Element_Any : constant Node_Id :=
- Build_Get_Aggregate_Element (Loc,
- Any => Any,
- Tc => Build_TypeCode_Call (Loc,
- Etype (Datum), Decls),
- Idx => New_Occurrence_Of (Counter, Loc));
+ Element_Any : Node_Id;
begin
+ declare
+ Element_TC : Node_Id;
+
+ begin
+ if Etype (Datum) = RTE (RE_Any) then
+
+ -- When Datum is an Any the Etype field is not
+ -- sufficient to determine the typecode of Datum
+ -- (which can be a TC_SEQUENCE or TC_ARRAY
+ -- depending on the value of Constrained).
+
+ -- Therefore we retrieve the typecode which has
+ -- been constructed in Append_Array_Traversal with
+ -- a call to Get_Any_Type.
+
+ Element_TC :=
+ Make_Function_Call (Loc,
+ Name => New_Occurrence_Of (
+ RTE (RE_Get_Any_Type), Loc),
+ Parameter_Associations => New_List (
+ New_Occurrence_Of (Entity (Datum), Loc)));
+ else
+ -- For non Any Datum we simply construct a typecode
+ -- matching the Etype of the Datum.
+
+ Element_TC := Build_TypeCode_Call
+ (Loc, Etype (Datum), Decls);
+ end if;
+
+ Element_Any :=
+ Build_Get_Aggregate_Element (Loc,
+ Any => Any,
+ TC => Element_TC,
+ Idx => New_Occurrence_Of (Counter, Loc));
+ end;
+
-- Note: here we *prepend* statements to Stmts, so
-- we must do it in reverse order.
New_Occurrence_Of (Counter, Loc),
Expression =>
Make_Op_Add (Loc,
- Left_Opnd =>
- New_Occurrence_Of (Counter, Loc),
- Right_Opnd =>
- Make_Integer_Literal (Loc, 1))));
+ Left_Opnd => New_Occurrence_Of (Counter, Loc),
+ Right_Opnd => Make_Integer_Literal (Loc, 1))));
if Nkind (Datum) /= N_Attribute_Reference then
if Etype (Datum) /= RTE (RE_Any) then
Set_Expression (Assignment,
- Build_From_Any_Call (
- Component_Type (Typ),
- Element_Any,
- Decls));
+ Build_From_Any_Call
+ (Component_Type (Typ), Element_Any, Decls));
else
Set_Expression (Assignment, Element_Any);
end if;
+
Prepend_To (Stmts, Assignment);
end if;
end FA_Ary_Add_Process_Element;
+ ------------------------
+ -- Local Declarations --
+ ------------------------
+
Counter : constant Entity_Id :=
Make_Defining_Identifier (Loc, Name_J);
new Append_Array_Traversal (
Subprogram => Fnam,
Arry => Res,
- Indices => New_List,
+ Indexes => New_List,
Add_Process_Element => FA_Ary_Add_Process_Element);
Res_Subtype_Indication : Node_Id :=
for J in 1 .. Ndim loop
Lnam := New_External_Name ('L', J);
Hnam := New_External_Name ('H', J);
- Indt := Etype (Indx);
+
+ -- Note, for empty arrays bounds may be out of
+ -- the range of Etype (Indx).
+
+ Indt := Base_Type (Etype (Indx));
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Lnam),
- Constant_Present =>
- True,
+ Constant_Present => True,
Object_Definition =>
New_Occurrence_Of (Indt, Loc),
Expression =>
- Build_From_Any_Call (
- Indt,
- Build_Get_Aggregate_Element (Loc,
- Any => Any_Parameter,
- Tc => Build_TypeCode_Call (Loc,
- Indt, Decls),
- Idx => Make_Integer_Literal (Loc, J - 1)),
+ Build_From_Any_Call
+ (Indt,
+ Build_Get_Aggregate_Element (Loc,
+ Any => Any_Parameter,
+ TC => Build_TypeCode_Call
+ (Loc, Indt, Decls),
+ Idx =>
+ Make_Integer_Literal (Loc, J - 1)),
Decls)));
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Hnam),
- Constant_Present =>
- True,
+
+ 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))),
+ OK_Convert_To
+ (Standard_Long_Integer,
+ 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)))),
+ OK_Convert_To
+ (Standard_Long_Integer,
+ Make_Function_Call (Loc,
+ Name =>
+ New_Occurrence_Of (RTE (
+ RE_Get_Nested_Sequence_Length
+ ), Loc),
+ Parameter_Associations =>
+ New_List (
+ New_Occurrence_Of (
+ Any_Parameter, Loc),
+ Make_Integer_Literal (Loc,
+ Intval => J))))),
+
Right_Opnd =>
Make_Integer_Literal (Loc, 1))))));
Initial_Counter_Value := Ndim;
Res_Subtype_Indication := Make_Subtype_Indication (Loc,
- Subtype_Mark =>
- Res_Subtype_Indication,
+ Subtype_Mark => Res_Subtype_Indication,
Constraint =>
Make_Index_Or_Discriminant_Constraint (Loc,
Constraints => Ranges));
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => Component_TC,
- Constant_Present => True,
- Object_Definition =>
+ Constant_Present => True,
+ Object_Definition =>
New_Occurrence_Of (RTE (RE_TypeCode), Loc),
- Expression =>
+ Expression =>
Build_TypeCode_Call (Loc,
Component_Type (Typ), Decls)));
- Append_From_Any_Array_Iterator (Stms,
- Any_Parameter, Counter);
+ Append_From_Any_Array_Iterator
+ (Stms, Any_Parameter, Counter);
Append_To (Stms,
- Make_Return_Statement (Loc,
+ Make_Simple_Return_Statement (Loc,
Expression => New_Occurrence_Of (Res, Loc)));
end;
elsif Is_Integer_Type (Typ) or else Is_Unsigned_Type (Typ) then
Append_To (Stms,
- Make_Return_Statement (Loc,
+ Make_Simple_Return_Statement (Loc,
Expression =>
- Unchecked_Convert_To (
- Typ,
- Build_From_Any_Call (
- Find_Numeric_Representation (Typ),
- New_Occurrence_Of (Any_Parameter, Loc),
- Decls))));
+ 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))))));
+ Use_Opaque_Representation := True;
+ end if;
- end;
+ if Use_Opaque_Representation then
+ Assign_Opaque_From_Any (Loc,
+ Stms => Stms,
+ Typ => Typ,
+ N => New_Occurrence_Of (Any_Parameter, Loc),
+ Target => Empty);
end if;
Decl :=
begin
return Make_Function_Call (Loc,
Name =>
- New_Occurrence_Of (
- RTE (RE_Get_Aggregate_Element), Loc),
+ New_Occurrence_Of (RTE (RE_Get_Aggregate_Element), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Any, Loc),
TC,
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_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
+ (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;
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;
+ Typ : Entity_Id := Etype (N);
+ U_Type : Entity_Id;
+ C_Type : Entity_Id;
+ Fnam : Entity_Id := Empty;
+ Lib_RE : RE_Id := RE_Null;
begin
- -- If N is a selected component, then maybe its Etype
- -- has not been set yet: try to use the Etype of the
- -- selector_name in that case.
+ -- If N is a selected component, then maybe its Etype has not been
+ -- set yet: try to use Etype of the selector_name in that case.
if No (Typ) and then Nkind (N) = N_Selected_Component then
Typ := Etype (Selector_Name (N));
end if;
+
pragma Assert (Present (Typ));
- -- The full view, if Typ is private; the completion,
- -- if Typ is incomplete.
+ -- Get full view for private type, completion for incomplete type
U_Type := Underlying_Type (Typ);
- -- First simple case where the To_Any function is present
- -- in the type's TSS.
+ -- 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.
+ -- For the subtype representing a generic actual type, go to the
+ -- actual type.
+
+ if Is_Generic_Actual_Type (U_Type) then
+ U_Type := Underlying_Type (Base_Type (U_Type));
+ end if;
+
+ -- For a standard subtype, go to the base type
if Sloc (U_Type) <= Standard_Location then
U_Type := Base_Type (U_Type);
if Present (Fnam) then
null;
+ -- Check first for Boolean and Character. These are enumeration
+ -- types, but we treat them specially, since they may require
+ -- special handling in the transfer protocol. However, this
+ -- special handling only applies if they have standard
+ -- representation, otherwise they are treated like any other
+ -- enumeration type.
+
elsif U_Type = Standard_Boolean then
Lib_RE := RE_TA_B;
elsif U_Type = RTE (RE_Long_Long_Unsigned) then
Lib_RE := RE_TA_LLU;
- elsif U_Type = Standard_String then
+ elsif Is_RTE (U_Type, RE_Unbounded_String) then
Lib_RE := RE_TA_String;
+ -- Special DSA types
+
+ elsif Is_RTE (U_Type, RE_Any_Container_Ptr) then
+ Lib_RE := RE_TA_A;
+ U_Type := Typ;
+
elsif U_Type = Underlying_Type (RTE (RE_TypeCode)) then
+
+ -- No corresponding FA_TC ???
+
Lib_RE := RE_TA_TC;
-- Other (non-primitive) types
Fnam := RTE (Lib_RE);
end if;
+ -- If Fnam is already analyzed, find the proper expected type,
+ -- else we have a newly constructed To_Any function and we know
+ -- that the expected type of its parameter is U_Type.
+
+ if Ekind (Fnam) = E_Function
+ and then Present (First_Formal (Fnam))
+ then
+ C_Type := Etype (First_Formal (Fnam));
+ else
+ C_Type := U_Type;
+ end if;
+
return
Make_Function_Call (Loc,
- Name => New_Occurrence_Of (Fnam, Loc),
- Parameter_Associations => New_List (N));
+ Name => New_Occurrence_Of (Fnam, Loc),
+ Parameter_Associations =>
+ New_List (OK_Convert_To (C_Type, N)));
end Build_To_Any_Call;
---------------------------
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);
+ Expr_Parameter : Entity_Id;
+ Any : Entity_Id;
+ Result_TC : Node_Id;
Any_Decl : Node_Id;
- Result_TC : Node_Id := Build_TypeCode_Call (Loc, Typ, Decls);
+
+ Use_Opaque_Representation : Boolean;
+ -- When True, use stream attributes and represent type as an
+ -- opaque sequence of bytes.
begin
- Fnam := Make_Stream_Procedure_Function_Name (Loc,
- Typ, Name_uTo_Any);
+ -- For a derived type, we can't go past the base type (to the
+ -- parent type) here, because that would cause the attribute's
+ -- formal parameter to have the wrong type; hence the Base_Type
+ -- check here.
+
+ if Is_Itype (Typ) and then Typ /= Base_Type (Typ) then
+ Build_To_Any_Function
+ (Loc => Loc,
+ Typ => Etype (Typ),
+ Decl => Decl,
+ Fnam => Fnam);
+ return;
+ end if;
+
+ Expr_Parameter := Make_Defining_Identifier (Loc, Name_E);
+ Any := Make_Defining_Identifier (Loc, Name_A);
+ Result_TC := Build_TypeCode_Call (Loc, Typ, Decls);
+
+ Fnam := Make_Helper_Function_Name (Loc, Typ, Name_To_Any);
Spec :=
Make_Function_Specification (Loc,
Defining_Unit_Name => Fnam,
Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- Expr_Parameter,
- Parameter_Type =>
- New_Occurrence_Of (Typ, Loc))),
- Subtype_Mark => New_Occurrence_Of (RTE (RE_Any), 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));
+ Defining_Identifier => Any,
+ Object_Definition => New_Occurrence_Of (RTE (RE_Any), Loc));
+
+ Use_Opaque_Representation := False;
+
+ if Has_Stream_Attribute_Definition
+ (Typ, TSS_Stream_Output, At_Any_Place => True)
+ or else
+ Has_Stream_Attribute_Definition
+ (Typ, TSS_Stream_Write, At_Any_Place => True)
+ then
+ -- If user-defined stream attributes are specified for this
+ -- type, use them and transmit data as an opaque sequence of
+ -- stream elements.
+
+ Use_Opaque_Representation := True;
+
+ elsif Is_Derived_Type (Typ) and then not Is_Tagged_Type (Typ) then
+
+ -- Non-tagged derived type: convert to root type
- 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));
+ Rt_Type : constant Entity_Id := Root_Type (Typ);
+ Expr : constant Node_Id :=
+ OK_Convert_To
+ (Rt_Type,
+ New_Occurrence_Of (Expr_Parameter, Loc));
begin
Set_Expression (Any_Decl, Build_To_Any_Call (Expr, Decls));
end;
elsif Is_Record_Type (Typ) and then not Is_Tagged_Type (Typ) then
+
+ -- Non-tagged record type
+
if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then
declare
- Rt_Type : constant Entity_Id
- := Etype (Typ);
- Expr : constant Node_Id
- := OK_Convert_To (
- Rt_Type,
- New_Occurrence_Of (Expr_Parameter, Loc));
+ 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));
+ Set_Expression
+ (Any_Decl, Build_To_Any_Call (Expr, Decls));
end;
+ -- Comment needed here (and label on declare block ???)
+
else
declare
- Disc : Entity_Id := Empty;
- Rdef : constant Node_Id :=
- Type_Definition (Declaration_Node (Typ));
- Counter : Int := 0;
+ 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
Counter : in out Int;
Rec : Entity_Id;
Field : Node_Id);
+ -- Processing routine for traversal below
procedure TA_Append_Record_Traversal is
new Append_Record_Traversal
New_Occurrence_Of (
RTE (RE_Add_Aggregate_Element), Loc),
Parameter_Associations => New_List (
- New_Occurrence_Of (Any, Loc),
+ New_Occurrence_Of (Container, Loc),
Build_To_Any_Call (Field_Ref, Decls))));
else
-- A variant part
- declare
- Variant : Node_Id;
+ 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;
+ Alt_List : constant List_Id := New_List;
Choice_List : List_Id;
Union_Any : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- New_Internal_Name ('U'));
+ Make_Temporary (Loc, 'V');
Struct_Any : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- New_Internal_Name ('S'));
+ Make_Temporary (Loc, 'S');
function Make_Discriminant_Reference
return Node_Id;
- -- Build a selected component for the
- -- discriminant of this variant part.
+ -- Build reference to the discriminant for this
+ -- variant part.
---------------------------------
-- Make_Discriminant_Reference --
Selector_Name =>
Chars (Name (Field)));
begin
- Set_Etype (Nod, Name (Field));
+ Set_Etype (Nod, Etype (Name (Field)));
return Nod;
end Make_Discriminant_Reference;
+ -- Start of processing for Variant_Part
+
begin
Append_To (Stmts,
Make_Block_Statement (Loc,
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Block_Stmts)));
+ -- Declare variant part aggregate (Union_Any).
+ -- Knowing the position of this VP in the
+ -- variant record, we can fetch the VP typecode
+ -- from Container.
+
Append_To (Block_Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => Union_Any,
Make_Integer_Literal (Loc,
Counter)))))));
+ -- Declare inner struct aggregate (which
+ -- contains the components of this VP).
+
Append_To (Block_Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => Struct_Any,
Parameter_Associations => New_List (
New_Occurrence_Of (Union_Any, Loc),
Make_Integer_Literal (Loc,
- Uint_0)))))));
+ Uint_1)))))));
+
+ -- Build case statement
Append_To (Block_Stmts,
Make_Case_Statement (Loc,
- Expression =>
- Make_Discriminant_Reference,
- Alternatives =>
- Alt_List));
+ 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);
+ VP_Stmts := New_List;
- -- Append discriminant value and inner struct
- -- to union aggregate.
+ -- Append discriminant val to union aggregate
Append_To (VP_Stmts,
Make_Procedure_Call_Statement (Loc,
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))));
+ Build_To_Any_Call
+ (Make_Discriminant_Reference,
+ Block_Decls))));
+
+ -- Populate inner struct aggregate
+
+ -- Struct_Counter should be reset before
+ -- handling a variant part. Indeed only one
+ -- of the case statement alternatives will be
+ -- executed at run time, so the counter must
+ -- start at 0 for every case statement.
+
+ Struct_Counter := 0;
+
+ TA_Append_Record_Traversal
+ (Stmts => VP_Stmts,
+ Clist => Component_List (Variant),
+ Container => Struct_Any,
+ Counter => Struct_Counter);
+
+ -- Append inner struct to union aggregate
Append_To (VP_Stmts,
Make_Procedure_Call_Statement (Loc,
Name =>
- New_Occurrence_Of (
- RTE (RE_Add_Aggregate_Element), Loc),
+ 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_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))))));
+ New_Occurrence_Of
+ (RTE (RE_Add_Aggregate_Element), Loc),
+ Parameter_Associations => New_List (
+ New_Occurrence_Of (Container, Loc),
+ New_Occurrence_Of
+ (Union_Any, Loc))));
Append_To (Alt_List,
Make_Case_Statement_Alternative (Loc,
Discrete_Choices => Choice_List,
- Statements =>
- VP_Stmts));
+ Statements => VP_Stmts));
+
Next_Non_Pragma (Variant);
end loop;
- end;
+ end Variant_Part;
end if;
+
+ Counter := Counter + 1;
end TA_Rec_Add_Process_Element;
begin
- -- First all discriminants
+ -- Records are encoded in a TC_STRUCT aggregate:
+
+ -- -- Outer aggregate (TC_STRUCT)
+ -- | [discriminant1]
+ -- | [discriminant2]
+ -- | ...
+ -- |
+ -- | [component1]
+ -- | [component2]
+ -- | ...
+
+ -- A component can be a common component or variant part
+
+ -- A variant part is encoded as a TC_UNION aggregate:
+
+ -- -- Variant Part Aggregate (TC_UNION)
+ -- | [discriminant choice for this Variant Part]
+ -- |
+ -- | -- Inner struct (TC_STRUCT)
+ -- | | [component1]
+ -- | | [component2]
+ -- | | ...
+
+ -- Let's start by building the outer aggregate. First we
+ -- construct Elements array containing all discriminants.
if Has_Discriminants (Typ) then
Disc := First_Discriminant (Typ);
-
while Present (Disc) loop
- 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)));
+ declare
+ Discriminant : constant Entity_Id :=
+ Make_Selected_Component (Loc,
+ Prefix =>
+ Expr_Parameter,
+ Selector_Name =>
+ Chars (Disc));
+
+ begin
+ Set_Etype (Discriminant, Etype (Disc));
+
+ Append_To (Elements,
+ Make_Component_Association (Loc,
+ Choices => New_List (
+ Make_Integer_Literal (Loc, Counter)),
+ Expression =>
+ Build_To_Any_Call (Discriminant, Decls)));
+ end;
+
Counter := Counter + 1;
Next_Discriminant (Disc);
end loop;
else
- -- Make elements an empty array
+ -- If there are no discriminants, we declare an empty
+ -- Elements array.
declare
Dummy_Any : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- Chars => New_Internal_Name ('A'));
+ Make_Temporary (Loc, 'A');
begin
Append_To (Decls,
end;
end if;
+ -- We build the result aggregate with discriminants
+ -- as the first elements.
+
Set_Expression (Any_Decl,
Make_Function_Call (Loc,
- Name => New_Occurrence_Of (
- RTE (RE_Any_Aggregate_Build), Loc),
+ 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
+ -- Then we append all the components to the result
+ -- aggregate.
TA_Append_Record_Traversal (Stms,
Clist => Component_List (Rdef),
end if;
elsif Is_Array_Type (Typ) then
+
+ -- Constrained and unconstrained array types
+
declare
Constrained : constant Boolean := Is_Constrained (Typ);
Counter : Entity_Id;
Datum : Node_Id)
is
- pragma Warnings (Off);
pragma Unreferenced (Counter);
- pragma Warnings (On);
Element_Any : Node_Id;
new Append_Array_Traversal (
Subprogram => Fnam,
Arry => Expr_Parameter,
- Indices => New_List,
+ Indexes => New_List,
Add_Process_Element => TA_Ary_Add_Process_Element);
Index : Node_Id;
end;
elsif Is_Integer_Type (Typ) or else Is_Unsigned_Type (Typ) then
+
+ -- Integer types
+
Set_Expression (Any_Decl,
Build_To_Any_Call (
OK_Convert_To (
Decls));
else
- -- Default: type is represented as an opaque sequence of bytes
+ -- Default case, including tagged types: opaque representation
+ Use_Opaque_Representation := True;
+ end if;
+
+ if Use_Opaque_Representation then
declare
- Strm : constant Entity_Id := Make_Defining_Identifier (Loc,
- New_Internal_Name ('S'));
+ Strm : constant Entity_Id := Make_Temporary (Loc, 'S');
+ -- Stream used to store data representation produced by
+ -- stream attribute.
begin
- -- Strm : aliased Buffer_Stream_Type;
+ -- Generate:
+ -- Strm : aliased Buffer_Stream_Type;
Append_To (Decls,
Make_Object_Declaration (Loc,
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);
+ -- Generate:
+ -- T'Output (Strm'Access, E);
Append_To (Stms,
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Typ, Loc),
Attribute_Name => Name_Output,
- Expressions => New_List (
+ Expressions => New_List (
Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Strm, Loc),
+ Prefix => New_Occurrence_Of (Strm, Loc),
Attribute_Name => Name_Access),
New_Occurrence_Of (Expr_Parameter, Loc))));
- -- BS_To_Any (Strm, A);
+ -- Generate:
+ -- BS_To_Any (Strm, A);
Append_To (Stms,
Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of (RTE (RE_BS_To_Any), 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);
+ -- Generate:
+ -- Release_Buffer (Strm);
Append_To (Stms,
Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of (RTE (RE_Release_Buffer), Loc),
+ Name => New_Occurrence_Of (RTE (RE_Release_Buffer), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Strm, Loc))));
end;
end if;
Append_To (Stms,
- Make_Return_Statement (Loc,
+ Make_Simple_Return_Statement (Loc,
Expression => New_Occurrence_Of (Any, Loc)));
Decl :=
Make_Subprogram_Body (Loc,
- Specification => Spec,
- Declarations => Decls,
+ Specification => Spec,
+ Declarations => Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Stms));
Typ : Entity_Id;
Decls : List_Id) return Node_Id
is
- U_Type : Entity_Id := Underlying_Type (Typ);
+ U_Type : Entity_Id := Underlying_Type (Typ);
-- The full view, if Typ is private; the completion,
-- if Typ is incomplete.
- Fnam : Entity_Id := Empty;
- Tnam : Entity_Id := Empty;
- Pnam : Entity_Id := Empty;
- Args : List_Id := Empty_List;
- Lib_RE : RE_Id := RE_Null;
-
- Expr : Node_Id;
+ 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);
+ Fnam := RTE (RE_TC_A);
else
-- First simple case where the TypeCode is present
-- in the type's TSS.
Fnam := Find_Inherited_TSS (U_Type, TSS_TypeCode);
+ end if;
- if Present (Fnam) then
-
- -- When a TypeCode TSS exists, it has a single parameter
- -- that is an anonymous access to the corresponding type.
- -- This parameter is not used in any way; its purpose is
- -- solely to provide overloading of the TSS.
-
- Tnam :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('T'));
- Pnam :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
-
- Append_To (Decls,
- Make_Full_Type_Declaration (Loc,
- Defining_Identifier => Tnam,
- Type_Definition =>
- Make_Access_To_Object_Definition (Loc,
- Subtype_Indication =>
- New_Occurrence_Of (U_Type, Loc))));
- Append_To (Decls,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Pnam,
- Constant_Present => True,
- Object_Definition => New_Occurrence_Of (Tnam, Loc),
-
- -- Use a variable here to force proper freezing of Tnam
+ -- For the subtype representing a generic actual type, go to the
+ -- actual type.
- Expression => Make_Null (Loc)));
+ if Is_Generic_Actual_Type (U_Type) then
+ U_Type := Underlying_Type (Base_Type (U_Type));
+ end if;
- -- Normally, calling _TypeCode with a null access parameter
- -- should raise Constraint_Error, but this check is
- -- suppressed for expanded code, and we do not care anyway
- -- because we do not actually ever use this value.
+ -- For a standard subtype, go to the base type
- Args := New_List (New_Occurrence_Of (Pnam, Loc));
- end if;
+ if Sloc (U_Type) <= Standard_Location then
+ U_Type := Base_Type (U_Type);
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 = RTE (RE_Long_Long_Unsigned) then
Lib_RE := RE_TC_LLU;
- elsif U_Type = Standard_String then
+ elsif Is_RTE (U_Type, RE_Unbounded_String) then
Lib_RE := RE_TC_String;
+ -- Special DSA types
+
+ elsif Is_RTE (U_Type, RE_Any_Container_Ptr) then
+ Lib_RE := RE_TC_A;
+
-- Other (non-primitive) types
else
-- Call the function
Expr :=
- Make_Function_Call (Loc,
- Name => New_Occurrence_Of (Fnam, Loc),
- Parameter_Associations => Args);
+ Make_Function_Call (Loc, Name => New_Occurrence_Of (Fnam, Loc));
-- Allow Expr to be used as arg to Build_To_Any_Call immediately
Stms : constant List_Id := New_List;
TCNam : constant Entity_Id :=
- Make_Stream_Procedure_Function_Name (Loc,
- Typ, Name_uTypeCode);
+ Make_Helper_Function_Name (Loc, Typ, Name_TypeCode);
Parameters : List_Id;
begin
Append_To (Parameter_List,
Make_Function_Call (Loc,
- Name =>
- New_Occurrence_Of (RTE (RE_TA_String), Loc),
+ Name => New_Occurrence_Of (RTE (RE_TA_Std_String), Loc),
Parameter_Associations => New_List (
Make_String_Literal (Loc, S))));
end Add_String_Parameter;
begin
Append_To (Parameter_List,
Make_Function_Call (Loc,
- Name =>
- New_Occurrence_Of (RTE (RE_TA_TC), Loc),
- Parameter_Associations => New_List (
- TC_Node)));
+ Name => New_Occurrence_Of (RTE (RE_TA_TC), Loc),
+ Parameter_Associations => New_List (TC_Node)));
end Add_TypeCode_Parameter;
------------------------
begin
Append_To (Parameter_List,
Make_Function_Call (Loc,
- Name =>
- New_Occurrence_Of (RTE (RE_TA_LI), Loc),
+ Name => New_Occurrence_Of (RTE (RE_TA_LI), Loc),
Parameter_Associations => New_List (Expr_Node)));
end Add_Long_Parameter;
procedure Return_Constructed_TypeCode (Kind : Entity_Id) is
begin
Append_To (Stms,
- Make_Return_Statement (Loc,
+ Make_Simple_Return_Statement (Loc,
Expression =>
- Make_Constructed_TypeCode (Kind, Parameters)));
+ Make_Constructed_TypeCode (Kind, Parameters)));
end Return_Constructed_TypeCode;
------------------
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);
+ Add_TypeCode_Parameter
+ (Build_TypeCode_Call (Loc, Etype (Field), Decls), Params);
Get_Name_String (Chars (Field));
Add_String_Parameter (String_From_Name_Buffer, Params);
Union_TC_Params : List_Id;
U_Name : constant Name_Id :=
- New_External_Name (Chars (Typ), 'U', -1);
+ New_External_Name (Chars (Typ), 'V', -1);
Name_Str : String_Id;
Struct_TC_Params : List_Id;
Dummy_Counter : Int := 0;
+ Choice_Index : Int := 0;
+
procedure Add_Params_For_Variant_Components;
-- Add a struct TypeCode and a corresponding member name
-- to the union parameter list.
-- Ordering of declarations is a complete mess in this
- -- area, it is supposed to be types/varibles, then
+ -- area, it is supposed to be types/variables, then
-- subprogram specs, then subprogram bodies ???
---------------------------------------
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);
+ Params);
+
+ Add_String_Parameter (Name_Str, Params);
-- Build union parameters
Add_TypeCode_Parameter
- (Discriminant_Type, Union_TC_Params);
+ (Build_TypeCode_Call
+ (Loc, Discriminant_Type, Decls),
+ Union_TC_Params);
+
Add_Long_Parameter (Default, Union_TC_Params);
Variant := First_Non_Pragma (Variants (Field));
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);
+
+ -- This variant possess a default choice.
+ -- We must therefore set the default
+ -- parameter to the current choice index. The
+ -- default parameter is by construction the
+ -- fourth in the Union_TC_Params list.
+
+ declare
+ Default_Node : constant Node_Id :=
+ Pick (Union_TC_Params, 4);
+
+ New_Default_Node : constant Node_Id :=
+ Make_Function_Call (Loc,
+ Name =>
+ New_Occurrence_Of
+ (RTE (RE_TA_LI), Loc),
+ Parameter_Associations =>
+ New_List (
+ Make_Integer_Literal
+ (Loc, Choice_Index)));
+ begin
+ Insert_Before (
+ Default_Node,
+ New_Default_Node);
+
+ Remove (Default_Node);
+ end;
+
+ -- Add a placeholder member label
+ -- for the default case.
+ -- It must be of the discriminant type.
+
+ declare
+ Exp : constant Node_Id :=
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of
+ (Discriminant_Type, Loc),
+ Attribute_Name => Name_First);
+ begin
+ Set_Etype (Exp, Discriminant_Type);
+ Append_To (Union_TC_Params,
+ Build_To_Any_Call (Exp, Decls));
+ end;
+
Add_Params_For_Variant_Components;
when others =>
- Append_To (Union_TC_Params,
- Build_To_Any_Call (Choice, Decls));
- Add_Params_For_Variant_Components;
+ -- Case of an explicit choice
+
+ declare
+ Exp : constant Node_Id :=
+ New_Copy_Tree (Choice);
+ begin
+ Append_To (Union_TC_Params,
+ Build_To_Any_Call (Exp, Decls));
+ end;
+
+ Add_Params_For_Variant_Components;
end case;
+ Next (Choice);
+ Choice_Index := Choice_Index + 1;
end loop;
Next_Non_Pragma (Variant);
end loop;
-
end;
end if;
end TC_Rec_Add_Process_Element;
Type_Name_Str : String_Id;
Type_Repo_Id_Str : String_Id;
+ -- Start of processing for Build_TypeCode_Function
+
begin
- pragma Assert (not Is_Itype (Typ));
+ -- For a derived type, we can't go past the base type (to the
+ -- parent type) here, because that would cause the attribute's
+ -- formal parameter to have the wrong type; hence the Base_Type
+ -- check here.
+
+ if Is_Itype (Typ) and then Typ /= Base_Type (Typ) then
+ Build_TypeCode_Function
+ (Loc => Loc,
+ Typ => Etype (Typ),
+ Decl => Decl,
+ Fnam => Fnam);
+ return;
+ end if;
+
Fnam := TCNam;
Spec :=
Make_Function_Specification (Loc,
- Defining_Unit_Name => Fnam,
+ Defining_Unit_Name => Fnam,
Parameter_Specifications => Empty_List,
- Subtype_Mark => New_Occurrence_Of (RTE (RE_TypeCode), Loc));
+ 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)
+ if Has_Stream_Attribute_Definition
+ (Typ, TSS_Stream_Output, At_Any_Place => True)
+ or else
+ Has_Stream_Attribute_Definition
+ (Typ, TSS_Stream_Write, At_Any_Place => True)
then
- declare
- Parent_Type : Entity_Id := Etype (Typ);
- begin
-
- if Is_Itype (Parent_Type) then
-
- -- Skip implicit base type
+ -- If user-defined stream attributes are specified for this
+ -- type, use them and transmit data as an opaque sequence of
+ -- stream elements.
- Parent_Type := Etype (Parent_Type);
- end if;
+ Return_Alias_TypeCode
+ (New_Occurrence_Of (RTE (RE_TC_Opaque), Loc));
- Return_Alias_TypeCode (
- Build_TypeCode_Call (Loc, Parent_Type, Decls));
- end;
+ elsif Is_Derived_Type (Typ) and then not Is_Tagged_Type (Typ) then
+ Return_Alias_TypeCode (
+ Build_TypeCode_Call (Loc, Etype (Typ), Decls));
- elsif Is_Integer_Type (Typ)
- or else Is_Unsigned_Type (Typ)
- then
+ 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
+ elsif Is_Record_Type (Typ) and then not Is_Tagged_Type (Typ) then
+
+ -- Record typecodes are encoded as follows:
+ -- -- TC_STRUCT
+ -- |
+ -- | [Name]
+ -- | [Repository Id]
+ --
+ -- Then for each discriminant:
+ --
+ -- | [Discriminant Type Code]
+ -- | [Discriminant Name]
+ -- | ...
+ --
+ -- Then for each component:
+ --
+ -- | [Component Type Code]
+ -- | [Component Name]
+ -- | ...
+ --
+ -- Variants components type codes are encoded as follows:
+ -- -- TC_UNION
+ -- |
+ -- | [Name]
+ -- | [Repository Id]
+ -- | [Discriminant Type Code]
+ -- | [Index of Default Variant Part or -1 for no default]
+ --
+ -- Then for each Variant Part :
+ --
+ -- | [VP Label]
+ -- |
+ -- | -- TC_STRUCT
+ -- | | [Variant Part Name]
+ -- | | [Variant Part Repository Id]
+ -- | |
+ -- | Then for each VP component:
+ -- | | [VP component Typecode]
+ -- | | [VP component Name]
+ -- | | ...
+ -- | --
+ -- |
+ -- | [VP Name]
+
if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then
- Return_Alias_TypeCode (
- Build_TypeCode_Call (Loc, Etype (Typ), Decls));
+ 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));
+ Type_Definition (Declaration_Node (Typ));
Dummy_Counter : Int := 0;
+
begin
- -- First all discriminants
+ -- Construct the discriminants typecodes
if Has_Discriminants (Typ) then
Disc := First_Discriminant (Typ);
end if;
+
while Present (Disc) loop
Add_TypeCode_Parameter (
Build_TypeCode_Call (Loc, Etype (Disc), Decls),
Next_Discriminant (Disc);
end loop;
- -- ... then all components
+ -- then the components typecodes
TC_Append_Record_Traversal
(Parameters, Component_List (Rdef),
Indx : Node_Id := First_Index (Typ);
begin
- Inner_TypeCode := Build_TypeCode_Call (Loc,
- Component_Type (Typ),
- Decls);
+ Inner_TypeCode :=
+ Build_TypeCode_Call (Loc, Component_Type (Typ), Decls);
for J in 1 .. Ndim loop
if Constrained then
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,
+ Prefix => New_Occurrence_Of (Typ, Loc),
+ Attribute_Name => Name_Length,
Expressions => New_List (
Make_Integer_Literal (Loc,
- Ndim - J + 1)))),
+ Intval => Ndim - J + 1)))),
Decls),
Build_To_Any_Call (Inner_TypeCode, Decls)));
Decl :=
Make_Subprogram_Body (Loc,
- Specification => Spec,
- Declarations => Decls,
+ Specification => Spec,
+ Declarations => Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Stms));
-- Find_Numeric_Representation --
---------------------------------
- function Find_Numeric_Representation (Typ : Entity_Id)
- return Entity_Id
+ function Find_Numeric_Representation
+ (Typ : Entity_Id) return Entity_Id
is
FST : constant Entity_Id := First_Subtype (Typ);
P_Size : constant Uint := Esize (FST);
Element_Expr : constant Node_Id :=
Make_Indexed_Component (Loc,
New_Occurrence_Of (Arry, Loc),
- Indices);
-
+ Indexes);
begin
Set_Etype (Element_Expr, Component_Type (Typ));
Add_Process_Element (Stmts,
return;
end if;
- Append_To (Indices,
+ Append_To (Indexes,
Make_Identifier (Loc, New_External_Name ('L', Depth)));
- if Constrained then
- Inner_Any := Any;
- Inner_Counter := Counter;
- else
+ if not Constrained or else Depth > 1 then
Inner_Any := Make_Defining_Identifier (Loc,
- New_External_Name ('A', Depth));
+ 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;
+ if Present (Counter) then
+ Inner_Counter := Make_Defining_Identifier (Loc,
+ New_External_Name ('J', Depth));
+ else
+ Inner_Counter := Empty;
end if;
- Append_Array_Traversal (Inner_Stmts,
- Any => Inner_Any,
- Counter => Inner_Counter,
- Depth => Depth + 1);
+ 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,
Make_Integer_Literal (Loc, Depth))))),
Statements => Inner_Stmts);
- if Constrained then
- Append_To (Stmts, Loop_Stm);
- return;
- end if;
-
declare
Decls : constant List_Id := New_List;
Dimen_Stmts : constant List_Id := New_List;
begin
if Depth = 1 then
- 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)));
+ 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),
+ Name => New_Occurrence_Of (RTE (RE_Content_Type), Loc),
Parameter_Associations => New_List (
Make_Identifier (Loc,
- New_External_Name ('T', Depth - 1))));
+ Chars => New_External_Name ('T', Depth - 1))));
end if;
Append_To (Decls,
Object_Definition => New_Occurrence_Of (
RTE (RE_TypeCode), Loc),
Expression => Inner_Any_TypeCode_Expr));
- 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)))));
+
+ 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_Integer_Literal (Loc, 0)));
end if;
- 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);
+ 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
+ -- Loop_Stm does appropriate processing for each element
-- of Inner_Any.
Append_To (Dimen_Stmts, Loop_Stm);
-- Link outer and inner any
- Add_Process_Element (Dimen_Stmts,
- Any => Any,
- Counter => Counter,
- Datum => New_Occurrence_Of (Inner_Any, Loc));
+ 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,
end;
end Append_Array_Traversal;
- -----------------------------------------
- -- Make_Stream_Procedure_Function_Name --
- -----------------------------------------
+ -------------------------------
+ -- Make_Helper_Function_Name --
+ -------------------------------
- function Make_Stream_Procedure_Function_Name
+ function Make_Helper_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.
+ declare
+ Serial : Nat := 0;
+ -- For tagged types that aren't frozen yet, generate the helper
+ -- under its canonical name so that it matches the primitive
+ -- spec. For all other cases, we use a serialized name so that
+ -- multiple generations of the same procedure do not clash.
- if Is_Tagged_Type (Typ) then
- return Make_Defining_Identifier (Loc, Nam);
- else
- return Make_Defining_Identifier (Loc,
+ begin
+ if Is_Tagged_Type (Typ) and then not Is_Frozen (Typ) then
+ null;
+ else
+ Serial := Increment_Serial_Number;
+ end if;
+
+ -- Use prefixed underscore to avoid potential clash with user
+ -- identifier (we use attribute names for Nam).
+
+ return
+ Make_Defining_Identifier (Loc,
Chars =>
- New_External_Name (Nam, ' ', Increment_Serial_Number));
- end if;
- end Make_Stream_Procedure_Function_Name;
+ New_External_Name
+ (Related_Id => Nam,
+ Suffix => ' ',
+ Suffix_Index => Serial,
+ Prefix => '_'));
+ end;
+ end Make_Helper_Function_Name;
end Helpers;
-----------------------------------
Pkg_Name := String_From_Name_Buffer;
Inst :=
Make_Package_Instantiation (Loc,
- Defining_Unit_Name =>
- Make_Defining_Identifier (Loc, New_Internal_Name ('R')),
+ Defining_Unit_Name => Make_Temporary (Loc, 'R'),
+
Name =>
New_Occurrence_Of (RTE (RE_RCI_Locator), Loc),
+
Generic_Associations => New_List (
Make_Generic_Association (Loc,
Selector_Name =>
Make_Identifier (Loc, Name_RCI_Name),
Explicit_Generic_Actual_Parameter =>
Make_String_Literal (Loc,
- Strval => Pkg_Name))));
+ Strval => Pkg_Name)),
+
+ Make_Generic_Association (Loc,
+ Selector_Name =>
+ Make_Identifier (Loc, Name_Version),
+ Explicit_Generic_Actual_Parameter =>
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Defining_Entity (Package_Spec), Loc),
+ Attribute_Name =>
+ Name_Version))));
- RCI_Locator_Table.Set (Defining_Unit_Name (Package_Spec),
- Defining_Unit_Name (Inst));
+ RCI_Locator_Table.Set
+ (Defining_Unit_Name (Package_Spec),
+ Defining_Unit_Name (Inst));
return Inst;
end RCI_Package_Locator;
is
Stub_Elements : constant Stub_Structure :=
Stubs_Table.Get (Full_View);
+
begin
+ -- For an RACW encountered before the freeze point of its designated
+ -- type, the stub type is generated at the point of the RACW declaration
+ -- but the primitives are generated only once the designated type is
+ -- frozen. That freeze can occur in another scope, for example when the
+ -- RACW is declared in a nested package. In that case we need to
+ -- reestablish the stub type's scope prior to generating its primitive
+ -- operations.
+
if Stub_Elements /= Empty_Stub_Structure then
- Add_RACW_Primitive_Declarations_And_Bodies
- (Full_View,
- Stub_Elements.RPC_Receiver_Decl,
- List_Containing (Declaration_Node (Full_View)));
+ declare
+ Saved_Scope : constant Entity_Id := Current_Scope;
+ Stubs_Scope : constant Entity_Id :=
+ Scope (Stub_Elements.Stub_Type);
+
+ begin
+ if Current_Scope /= Stubs_Scope then
+ Push_Scope (Stubs_Scope);
+ end if;
+
+ Add_RACW_Primitive_Declarations_And_Bodies
+ (Full_View,
+ Stub_Elements.RPC_Receiver_Decl,
+ Stub_Elements.Body_Decls);
+
+ if Current_Scope /= Saved_Scope then
+ Pop_Scope;
+ end if;
+ end;
end if;
end Remote_Types_Tagged_Full_View_Encountered;
-------------------
function Scope_Of_Spec (Spec : Node_Id) return Entity_Id is
- Unit_Name : Node_Id := Defining_Unit_Name (Spec);
+ 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;
begin
if Nkind (Spec) = N_Function_Specification then
Set_Ekind (Snam, E_Function);
- Set_Etype (Snam, Entity (Subtype_Mark (Spec)));
+ Set_Etype (Snam, Entity (Result_Definition (Spec)));
else
Set_Ekind (Snam, E_Procedure);
Set_Etype (Snam, Standard_Void_Type);
(Loc : Source_Ptr;
Decls : List_Id;
RPC_Receiver : Entity_Id;
- Stub_Elements : Stub_Structure) is
+ 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);
+ 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);
+ GARLIC_Support.Add_Obj_RPC_Receiver_Completion
+ (Loc, Decls, RPC_Receiver, Stub_Elements);
end case;
end Specific_Add_Obj_RPC_Receiver_Completion;
Stub_Type : Entity_Id;
Stub_Type_Access : Entity_Id;
RPC_Receiver_Decl : Node_Id;
- Declarations : List_Id) is
+ Body_Decls : List_Id)
+ is
begin
case Get_PCS_Name is
when Name_PolyORB_DSA =>
- PolyORB_Support.Add_RACW_Features (
- RACW_Type,
- Desig,
- Stub_Type,
- Stub_Type_Access,
- RPC_Receiver_Decl,
- Declarations);
+ PolyORB_Support.Add_RACW_Features
+ (RACW_Type,
+ Desig,
+ Stub_Type,
+ Stub_Type_Access,
+ RPC_Receiver_Decl,
+ Body_Decls);
when others =>
- GARLIC_Support.Add_RACW_Features (
- RACW_Type,
- Stub_Type,
- Stub_Type_Access,
- RPC_Receiver_Decl,
- Declarations);
+ GARLIC_Support.Add_RACW_Features
+ (RACW_Type,
+ Stub_Type,
+ Stub_Type_Access,
+ RPC_Receiver_Decl,
+ Body_Decls);
end case;
end Specific_Add_RACW_Features;
procedure Specific_Add_RAST_Features
(Vis_Decl : Node_Id;
- RAS_Type : Entity_Id) is
+ RAS_Type : Entity_Id)
+ is
begin
case Get_PCS_Name is
when Name_PolyORB_DSA =>
procedure Specific_Add_Receiving_Stubs_To_Declarations
(Pkg_Spec : Node_Id;
- Decls : List_Id)
+ Decls : List_Id;
+ Stmts : List_Id)
is
begin
case Get_PCS_Name is
when Name_PolyORB_DSA =>
- PolyORB_Support.Add_Receiving_Stubs_To_Declarations (
- Pkg_Spec, Decls);
+ PolyORB_Support.Add_Receiving_Stubs_To_Declarations
+ (Pkg_Spec, Decls, Stmts);
when others =>
- GARLIC_Support.Add_Receiving_Stubs_To_Declarations (
- Pkg_Spec, Decls);
+ GARLIC_Support.Add_Receiving_Stubs_To_Declarations
+ (Pkg_Spec, Decls, Stmts);
end case;
end Specific_Add_Receiving_Stubs_To_Declarations;
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);
+ 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);
+ 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;
Subp_Index,
Stmts,
Decl);
+
when others =>
GARLIC_Support.Build_RPC_Receiver_Body
(RPC_Receiver,
(Loc : Source_Ptr;
Decls : List_Id;
RCI_Locator : Entity_Id;
- Controlling_Parameter : Entity_Id) return RPC_Target is
+ 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);
+ 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);
+ return
+ GARLIC_Support.Build_Stub_Target
+ (Loc, Decls, RCI_Locator, Controlling_Parameter);
end case;
end Specific_Build_Stub_Target;
procedure Specific_Build_Stub_Type
(RACW_Type : Entity_Id;
- Stub_Type : Entity_Id;
- Stub_Type_Decl : out Node_Id;
+ Stub_Type_Comps : out List_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);
+ PolyORB_Support.Build_Stub_Type
+ (RACW_Type, Stub_Type_Comps, RPC_Receiver_Decl);
+
when others =>
- GARLIC_Support.Build_Stub_Type (
- RACW_Type, Stub_Type,
- Stub_Type_Decl, RPC_Receiver_Decl);
+ GARLIC_Support.Build_Stub_Type
+ (RACW_Type, Stub_Type_Comps, RPC_Receiver_Decl);
end case;
end Specific_Build_Stub_Type;
+ -----------------------------------------------
+ -- Specific_Build_Subprogram_Receiving_Stubs --
+ -----------------------------------------------
+
function Specific_Build_Subprogram_Receiving_Stubs
(Vis_Decl : Node_Id;
Asynchronous : Boolean;
Dynamically_Asynchronous : Boolean := False;
Stub_Type : Entity_Id := Empty;
RACW_Type : Entity_Id := Empty;
- Parent_Primitive : Entity_Id := Empty) return Node_Id is
+ 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);
+ 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);
+ return
+ GARLIC_Support.Build_Subprogram_Receiving_Stubs
+ (Vis_Decl,
+ Asynchronous,
+ Dynamically_Asynchronous,
+ Stub_Type,
+ RACW_Type,
+ Parent_Primitive);
end case;
end Specific_Build_Subprogram_Receiving_Stubs;
+ -------------------------------
+ -- Transmit_As_Unconstrained --
+ -------------------------------
+
+ function Transmit_As_Unconstrained (Typ : Entity_Id) return Boolean is
+ begin
+ return
+ not (Is_Elementary_Type (Typ) or else Is_Constrained (Typ))
+ or else (Is_Access_Type (Typ) and then Can_Never_Be_Null (Typ));
+ end Transmit_As_Unconstrained;
+
--------------------------
-- Underlying_RACW_Type --
--------------------------
end if;
return
- Etype (Subtype_Indication (
- Component_Definition (
- First (Component_Items (Component_List (
- Type_Definition (Declaration_Node (Record_Type))))))));
+ Etype (Subtype_Indication
+ (Component_Definition
+ (First (Component_Items
+ (Component_List
+ (Type_Definition
+ (Declaration_Node (Record_Type))))))));
end Underlying_RACW_Type;
end Exp_Dist;
OSDN Git Service
