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