-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
with Einfo; use Einfo;
with Elists; use Elists;
with Exp_Atag; use Exp_Atag;
+with Exp_Disp; use Exp_Disp;
with Exp_Strm; use Exp_Strm;
with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
with 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;
package body Exp_Dist is
-- The following model has been used to implement distributed objects:
- -- given a designated type D and a RACW type R, then a record of the
- -- form:
+ -- given a designated type D and a RACW type R, then a record of the form:
-- type Stub is tagged record
-- [...declaration similar to s-parint.ads RACW_Stub_Type...]
-- is built. This type has two properties:
- -- 1) Since it has the same structure than RACW_Stub_Type, it can be
- -- converted to and from this type to make it suitable for
+ -- 1) Since it has the same structure as RACW_Stub_Type, it can
+ -- be converted to and from this type to make it suitable for
-- System.Partition_Interface.Get_Unique_Remote_Pointer in order
- -- to avoid memory leaks when the same remote object arrive on the
+ -- to avoid memory leaks when the same remote object arrives on the
-- same partition through several paths;
-- 2) It also has the same dispatching table as the designated type D,
-- RCI subprograms are numbered starting at 2. The RCI receiver for
-- an RCI package can thus identify calls received through remote
-- access-to-subprogram dereferences by the fact that they have a
- -- (primitive) subprogram id of 0, and 1 is used for the internal
- -- RAS information lookup operation. (This is for the Garlic code
- -- generation, where subprograms are identified by numbers; in the
- -- PolyORB version, they are identified by name, with a numeric suffix
- -- for homonyms.)
+ -- (primitive) subprogram id of 0, and 1 is used for the internal RAS
+ -- information lookup operation. (This is for the Garlic code generation,
+ -- where subprograms are identified by numbers; in the PolyORB version,
+ -- they are identified by name, with a numeric suffix for homonyms.)
type Hash_Index is range 0 .. 50;
-----------------------
function Hash (F : Entity_Id) return Hash_Index;
- -- DSA expansion associates stubs to distributed object types using
- -- a hash table on entity ids.
+ -- DSA expansion associates stubs to distributed object types using a hash
+ -- table on entity ids.
function Hash (F : Name_Id) return Hash_Index;
-- The generation of subprogram identifiers requires an overload counter
- -- to be associated with each remote subprogram names. These counters
- -- are maintained in a hash table on name ids.
+ -- to be associated with each remote subprogram name. These counters are
+ -- maintained in a hash table on name ids.
type Subprogram_Identifiers is record
Str_Identifier : String_Id;
Key => Entity_Id,
Hash => Hash,
Equal => "=");
- -- Mapping between a remote subprogram and the corresponding
- -- subprogram identifiers.
+ -- Mapping between a remote subprogram and the corresponding subprogram
+ -- identifiers.
package Overload_Counter_Table is
new Simple_HTable (Header_Num => Hash_Index,
Key => Name_Id,
Hash => Hash,
Equal => "=");
- -- Mapping between a subprogram name and an integer that
- -- counts the number of defining subprogram names with that
- -- Name_Id encountered so far in a given context (an interface).
+ -- Mapping between a subprogram name and an integer that counts the number
+ -- of defining subprogram names with that Name_Id encountered so far in a
+ -- given context (an interface).
function Get_Subprogram_Ids (Def : Entity_Id) return Subprogram_Identifiers;
function Get_Subprogram_Id (Def : Entity_Id) return String_Id;
function Build_Remote_Subprogram_Proxy_Type
(Loc : Source_Ptr;
ACR_Expression : Node_Id) return Node_Id;
- -- Build and return a tagged record type definition for an RCI
- -- subprogram proxy type.
- -- ACR_Expression is use as the initialization value for
- -- the All_Calls_Remote component.
+ -- Build and return a tagged record type definition for an RCI subprogram
+ -- proxy type. ACR_Expression is used as the initialization value for the
+ -- All_Calls_Remote component.
function Build_Get_Unique_RP_Call
(Loc : Source_Ptr;
New_Name : Name_Id := No_Name) return Node_Id;
-- Build the calling stub for a given subprogram with the subprogram ID
-- being Subp_Id. If Stub_Type is given, then the "addr" field of
- -- parameters of this type will be marshalled instead of the object
- -- itself. It will then be converted into Stub_Type before performing
- -- the real call. If Dynamically_Asynchronous is True, then it will be
- -- computed at run time whether the call is asynchronous or not.
- -- Otherwise, the value of the formal Asynchronous will be used.
- -- If Locator is not Empty, it will be used instead of RCI_Cache. If
- -- New_Name is given, then it will be used instead of the original name.
+ -- parameters of this type will be marshalled instead of the object itself.
+ -- It will then be converted into Stub_Type before performing the real
+ -- call. If Dynamically_Asynchronous is True, then it will be computed at
+ -- run time whether the call is asynchronous or not. Otherwise, the value
+ -- of the formal Asynchronous will be used. If Locator is not Empty, it
+ -- will be used instead of RCI_Cache. If New_Name is given, then it will
+ -- be used instead of the original name.
function Build_RPC_Receiver_Specification
(RPC_Receiver : Entity_Id;
-- 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;
- Decls : List_Id);
+ procedure Add_Calling_Stubs_To_Declarations (Pkg_Spec : Node_Id);
-- Add calling stubs to the declarative part
function Could_Be_Asynchronous (Spec : Node_Id) return Boolean;
-- Return True if nothing prevents the program whose specification is
- -- given to be asynchronous (i.e. no out parameter).
+ -- given to be asynchronous (i.e. no [IN] OUT parameters).
function Pack_Entity_Into_Stream_Access
(Loc : Source_Ptr;
(Loc : Source_Ptr;
Prefix : Entity_Id;
Selector_Name : Name_Id) return Node_Id;
- -- Return a selected_component whose prefix denotes the given entity,
- -- and with the given Selector_Name.
+ -- Return a selected_component whose prefix denotes the given entity, and
+ -- with the given Selector_Name.
function Scope_Of_Spec (Spec : Node_Id) return Entity_Id;
-- Return the scope represented by a given spec
(Typ : Entity_Id;
Nam : Entity_Id;
TSS_Nam : TSS_Name_Type);
- -- Create a renaming declaration of subprogram Nam,
- -- and register it as a TSS for Typ with name TSS_Nam.
+ -- Create a renaming declaration of subprogram Nam, and register it as a
+ -- TSS for Typ with name TSS_Nam.
function Need_Extra_Constrained (Parameter : Node_Id) return Boolean;
-- Return True if the current parameter needs an extra formal to reflect
procedure Specific_Build_Stub_Type
(RACW_Type : Entity_Id;
- Stub_Type : Entity_Id;
- Stub_Type_Decl : out Node_Id;
+ Stub_Type_Comps : out List_Id;
RPC_Receiver_Decl : out Node_Id);
- -- Build a type declaration for the stub type associated with an RACW
- -- type, and the necessary RPC receiver, if applicable. PCS-specific
+ -- Build a components list for the stub type associated with an RACW type,
+ -- and build the necessary RPC receiver, if applicable. PCS-specific
-- ancillary subprogram for Add_Stub_Type. If no RPC receiver declaration
-- is generated, then RPC_Receiver_Decl is set to Empty.
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
procedure Build_Stub_Type
(RACW_Type : Entity_Id;
- Stub_Type : Entity_Id;
- Stub_Type_Decl : out Node_Id;
+ Stub_Type_Comps : out List_Id;
RPC_Receiver_Decl : out Node_Id);
function Build_Subprogram_Receiving_Stubs
end GARLIC_Support;
+ ---------------------
+ -- PolyORB_Support --
+ ---------------------
+
package PolyORB_Support is
-- Support for generating DSA code that uses the PolyORB PCS
procedure Build_Stub_Type
(RACW_Type : Entity_Id;
- Stub_Type : Entity_Id;
- Stub_Type_Decl : out Node_Id;
+ Stub_Type_Comps : out List_Id;
RPC_Receiver_Decl : out Node_Id);
function Build_Subprogram_Receiving_Stubs
-- 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
-- for entity E (a distributed object type or operation): one
-- containing the name of E, the second containing its repository id.
+ procedure Assign_Opaque_From_Any
+ (Loc : Source_Ptr;
+ Stms : List_Id;
+ Typ : Entity_Id;
+ N : Node_Id;
+ Target : Entity_Id);
+ -- For a Target object of type Typ, which has opaque representation
+ -- as a sequence of octets determined by stream attributes (which
+ -- includes all limited types), append code to Stmts performing the
+ -- equivalent of:
+ -- Target := Typ'From_Any (N)
+ --
+ -- or, if Target is Empty:
+ -- return Typ'From_Any (N)
+
end Helpers;
end PolyORB_Support;
-- since this require separate mechanisms ('Input is a function while
-- 'Read is a procedure).
+ generic
+ with procedure Process_Subprogram_Declaration (Decl : Node_Id);
+ -- Generate calling or receiving stub for this subprogram declaration
+
+ procedure Build_Package_Stubs (Pkg_Spec : Node_Id);
+ -- Recursively visit the given RCI Package_Specification, calling
+ -- Process_Subprogram_Declaration for each remote subprogram.
+
+ -------------------------
+ -- Build_Package_Stubs --
+ -------------------------
+
+ procedure Build_Package_Stubs (Pkg_Spec : Node_Id) is
+ Decls : constant List_Id := Visible_Declarations (Pkg_Spec);
+ Decl : Node_Id;
+
+ procedure Visit_Nested_Pkg (Nested_Pkg_Decl : Node_Id);
+ -- Recurse for the given nested package declaration
+
+ -----------------------
+ -- Visit_Nested_Spec --
+ -----------------------
+
+ procedure Visit_Nested_Pkg (Nested_Pkg_Decl : Node_Id) is
+ Nested_Pkg_Spec : constant Node_Id := Specification (Nested_Pkg_Decl);
+ begin
+ Push_Scope (Scope_Of_Spec (Nested_Pkg_Spec));
+ Build_Package_Stubs (Nested_Pkg_Spec);
+ Pop_Scope;
+ end Visit_Nested_Pkg;
+
+ -- Start of processing for Build_Package_Stubs
+
+ begin
+ Decl := First (Decls);
+ while Present (Decl) loop
+ case Nkind (Decl) is
+ when N_Subprogram_Declaration =>
+
+ -- Note: we test Comes_From_Source on Spec, not Decl, because
+ -- in the case of a subprogram instance, only the specification
+ -- (not the declaration) is marked as coming from source.
+
+ if Comes_From_Source (Specification (Decl)) then
+ Process_Subprogram_Declaration (Decl);
+ end if;
+
+ when N_Package_Declaration =>
+
+ -- Case of a nested package or package instantiation coming
+ -- from source. Note that the anonymous wrapper package for
+ -- subprogram instances is not flagged Is_Generic_Instance at
+ -- this point, so there is a distinct circuit to handle them
+ -- (see case N_Subprogram_Instantiation below).
+
+ declare
+ Pkg_Ent : constant Entity_Id :=
+ Defining_Unit_Name (Specification (Decl));
+ begin
+ if Comes_From_Source (Decl)
+ or else
+ (Is_Generic_Instance (Pkg_Ent)
+ and then Comes_From_Source
+ (Get_Package_Instantiation_Node (Pkg_Ent)))
+ then
+ Visit_Nested_Pkg (Decl);
+ end if;
+ end;
+
+ when N_Subprogram_Instantiation =>
+
+ -- The subprogram declaration for an instance of a generic
+ -- subprogram is wrapped in a package that does not come from
+ -- source, so we need to explicitly traverse it here.
+
+ if Comes_From_Source (Decl) then
+ Visit_Nested_Pkg (Instance_Spec (Decl));
+ end if;
+
+ when others =>
+ null;
+ end case;
+ Next (Decl);
+ end loop;
+ end Build_Package_Stubs;
+
---------------------------------------
-- Add_Calling_Stubs_To_Declarations --
---------------------------------------
- procedure Add_Calling_Stubs_To_Declarations
- (Pkg_Spec : Node_Id;
- Decls : List_Id)
- is
+ procedure Add_Calling_Stubs_To_Declarations (Pkg_Spec : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (Pkg_Spec);
+
Current_Subprogram_Number : Int := First_RCI_Subprogram_Id;
-- Subprogram id 0 is reserved for calls received from
-- remote access-to-subprogram dereferences.
- Current_Declaration : Node_Id;
- Loc : constant Source_Ptr := Sloc (Pkg_Spec);
- RCI_Instantiation : Node_Id;
- Subp_Stubs : Node_Id;
- Subp_Str : String_Id;
+ RCI_Instantiation : Node_Id;
+
+ procedure Visit_Subprogram (Decl : Node_Id);
+ -- Generate calling stub for one remote subprogram
+
+ ----------------------
+ -- Visit_Subprogram --
+ ----------------------
+
+ procedure Visit_Subprogram (Decl : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (Decl);
+ Spec : constant Node_Id := Specification (Decl);
+ Subp_Stubs : Node_Id;
+
+ Subp_Str : String_Id;
+ pragma Warnings (Off, Subp_Str);
+
+ begin
+ Assign_Subprogram_Identifier
+ (Defining_Unit_Name (Spec), Current_Subprogram_Number, Subp_Str);
+
+ Subp_Stubs :=
+ Build_Subprogram_Calling_Stubs
+ (Vis_Decl => Decl,
+ Subp_Id =>
+ Build_Subprogram_Id (Loc, Defining_Unit_Name (Spec)),
+ Asynchronous =>
+ Nkind (Spec) = N_Procedure_Specification
+ and then Is_Asynchronous (Defining_Unit_Name (Spec)));
- pragma Warnings (Off, Subp_Str);
+ 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
RCI_Instantiation := RCI_Package_Locator (Loc, Pkg_Spec);
RCI_Cache := Defining_Unit_Name (RCI_Instantiation);
- Append_To (Decls, RCI_Instantiation);
+ Append_To (Visible_Declarations (Pkg_Spec), RCI_Instantiation);
Analyze (RCI_Instantiation);
-- For each subprogram declaration visible in the spec, we do build a
-- body. We also increment a counter to assign a different Subprogram_Id
- -- to each subprograms. The receiving stubs processing do use the same
+ -- to each subprogram. The receiving stubs processing uses the same
-- mechanism and will thus assign the same Id and do the correct
-- dispatching.
Overload_Counter_Table.Reset;
PolyORB_Support.Reserve_NamingContext_Methods;
- Current_Declaration := First (Visible_Declarations (Pkg_Spec));
- while Present (Current_Declaration) loop
- if Nkind (Current_Declaration) = N_Subprogram_Declaration
- and then Comes_From_Source (Current_Declaration)
- then
- Assign_Subprogram_Identifier
- (Defining_Unit_Name (Specification (Current_Declaration)),
- Current_Subprogram_Number,
- Subp_Str);
-
- Subp_Stubs :=
- Build_Subprogram_Calling_Stubs (
- Vis_Decl => Current_Declaration,
- Subp_Id =>
- Build_Subprogram_Id (Loc,
- Defining_Unit_Name (Specification (Current_Declaration))),
- Asynchronous =>
- Nkind (Specification (Current_Declaration)) =
- N_Procedure_Specification
- and then
- Is_Asynchronous (Defining_Unit_Name (Specification
- (Current_Declaration))));
-
- Append_To (Decls, Subp_Stubs);
- Analyze (Subp_Stubs);
-
- Current_Subprogram_Number := Current_Subprogram_Number + 1;
- end if;
+ Visit_Spec (Pkg_Spec);
- Next (Current_Declaration);
- end loop;
+ Pop_Scope;
end Add_Calling_Stubs_To_Declarations;
-----------------------------
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.
end if;
if not Is_RAS then
- RPC_Receiver :=
- Make_Defining_Identifier (Loc,
- Chars => New_Internal_Name ('P'));
+ RPC_Receiver := Make_Temporary (Loc, 'P');
Specific_Build_RPC_Receiver_Body
(RPC_Receiver => RPC_Receiver,
end if;
-- Build callers, receivers for every primitive operations and a RPC
- -- receiver for this type.
+ -- receiver for this type. Note that we use Direct_Primitive_Operations,
+ -- not Primitive_Operations, because we really want just the primitives
+ -- of the tagged type itself, and in the case of a tagged synchronized
+ -- type we do not want to get the primitives of the corresponding
+ -- record type).
- if Present (Primitive_Operations (Designated_Type)) then
+ if Present (Direct_Primitive_Operations (Designated_Type)) then
Overload_Counter_Table.Reset;
Current_Primitive_Elmt :=
- First_Elmt (Primitive_Operations (Designated_Type));
+ First_Elmt (Direct_Primitive_Operations (Designated_Type));
while Current_Primitive_Elmt /= No_Elmt loop
Current_Primitive := Node (Current_Primitive_Elmt);
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))
+ Is_TSS (Current_Primitive, TSS_Stream_Write)
+ or else
+ Is_Predefined_Interface_Primitive (Current_Primitive))
and then not Is_Hidden (Current_Primitive)
then
-- The first thing to do is build an up-to-date copy of the
- -- spec with all the formals referencing Designated_Type
+ -- spec with all the formals referencing Controlling_Type
-- transformed into formals referencing Stub_Type. Since this
-- primitive may have been inherited, go back the alias chain
-- until the real primitive has been found.
- Current_Primitive_Alias := Current_Primitive;
- while Present (Alias (Current_Primitive_Alias)) loop
- pragma Assert
- (Current_Primitive_Alias
- /= Alias (Current_Primitive_Alias));
- Current_Primitive_Alias := Alias (Current_Primitive_Alias);
- end loop;
+ Current_Primitive_Alias := Ultimate_Alias (Current_Primitive);
-- Copy the spec from the original declaration for the purpose
-- of declaring an overriding subprogram: we need to replace
-- the type of each controlling formal with Stub_Type. The
- -- primitive may have been declared for Designated_Type or
+ -- 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,
RACW_Type => Stub_Elements.RACW_Type,
Parent_Primitive => Current_Primitive);
- Current_Receiver := Defining_Unit_Name (
- Specification (Current_Receiver_Body));
+ Current_Receiver :=
+ Defining_Unit_Name (Specification (Current_Receiver_Body));
Append_To (Body_Decls, Current_Receiver_Body);
Param_Assoc : constant List_Id := New_List;
Stmts : constant List_Id := New_List;
- RAS_Parameter : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- Chars => New_Internal_Name ('P'));
+ RAS_Parameter : constant Entity_Id := Make_Temporary (Loc, 'P');
Is_Function : constant Boolean :=
Nkind (Type_Def) = N_Access_Function_Definition;
is
Loc : constant Source_Ptr := Sloc (RACW_Type);
- Stub_Elements : constant Stub_Structure :=
- Stubs_Table.Get (Designated_Type);
+ Stub_Elements : constant Stub_Structure :=
+ Stubs_Table.Get (Designated_Type);
+ Stub_Type_Comps : List_Id;
Stub_Type_Decl : Node_Id;
Stub_Type_Access_Decl : Node_Id;
end if;
Existing := False;
- Stub_Type :=
- Make_Defining_Identifier (Loc,
- Chars => New_Internal_Name ('S'));
+ Stub_Type := Make_Temporary (Loc, 'S');
Set_Ekind (Stub_Type, E_Record_Type);
Set_Is_RACW_Stub_Type (Stub_Type);
Stub_Type_Access :=
Chars => New_External_Name
(Related_Id => Chars (Stub_Type), Suffix => 'A'));
- Specific_Build_Stub_Type
- (RACW_Type, Stub_Type,
- Stub_Type_Decl, RPC_Receiver_Decl);
+ Specific_Build_Stub_Type (RACW_Type, Stub_Type_Comps, RPC_Receiver_Decl);
+
+ Stub_Type_Decl :=
+ Make_Full_Type_Declaration (Loc,
+ Defining_Identifier => Stub_Type,
+ Type_Definition =>
+ Make_Record_Definition (Loc,
+ Tagged_Present => True,
+ Limited_Present => True,
+ Component_List =>
+ Make_Component_List (Loc,
+ Component_Items => Stub_Type_Comps)));
+
+ -- Does the stub type need to explicitly implement interfaces from the
+ -- designated type???
+
+ -- In particular are there issues in the case where the designated type
+ -- is a synchronized interface???
Stub_Type_Access_Decl :=
Make_Full_Type_Declaration (Loc,
Append_To (Decls, Stub_Type_Access_Decl);
Analyze (Last (Decls));
- -- This is in no way a type derivation, but we fake it to make sure that
- -- the dispatching table gets built with the corresponding primitive
- -- operations at the right place.
+ -- We can't directly derive the stub type from the designated type,
+ -- because we don't want any components or discriminants from the real
+ -- type, so instead we manually fake a derivation to get an appropriate
+ -- dispatch table.
Derive_Subprograms (Parent_Type => Designated_Type,
Derived_Type => Stub_Type);
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
Get_Name_String (N);
- -- Homonym handling: as in Exp_Dbug, but much simpler,
- -- because the only entities for which we have to generate
- -- names here need only to be disambiguated within their
- -- own scope.
+ -- Homonym handling: as in Exp_Dbug, but much simpler, because the only
+ -- entities for which we have to generate names here need only to be
+ -- disambiguated within their own scope.
if Overload_Order > 1 then
Name_Buffer (Name_Len + 1 .. Name_Len + 2) := "__";
end if;
Id := String_From_Name_Buffer;
- Subprogram_Identifier_Table.Set (Def,
- Subprogram_Identifiers'(Str_Identifier => Id, Int_Identifier => Spn));
+ Subprogram_Identifier_Table.Set
+ (Def,
+ Subprogram_Identifiers'(Str_Identifier => Id, Int_Identifier => Spn));
end Assign_Subprogram_Identifier;
-------------------------------------
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.
declare
Constant_Object : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- New_Internal_Name ('P'));
+ Make_Temporary (Loc, 'P');
+
begin
Set_Defining_Identifier
(Last (Decls), Constant_Object);
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.
-- Start of processing for Build_Subprogram_Calling_Stubs
begin
- Subp_Spec := Copy_Specification (Loc,
- Spec => Specification (Vis_Decl),
- New_Name => New_Name);
+ Subp_Spec :=
+ Copy_Specification (Loc,
+ Spec => Specification (Vis_Decl),
+ New_Name => New_Name);
if Locator = Empty then
RCI_Locator := RCI_Cache;
---------------------------------------------
procedure Expand_All_Calls_Remote_Subprogram_Call (N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
Called_Subprogram : constant Entity_Id := Entity (Name (N));
RCI_Package : constant Entity_Id := Scope (Called_Subprogram);
- Loc : constant Source_Ptr := Sloc (N);
- RCI_Locator : Node_Id;
- RCI_Cache : Entity_Id;
+ RCI_Locator_Decl : Node_Id;
+ RCI_Locator : Entity_Id;
Calling_Stubs : Node_Id;
E_Calling_Stubs : Entity_Id;
E_Calling_Stubs := RCI_Calling_Stubs_Table.Get (Called_Subprogram);
if E_Calling_Stubs = Empty then
- RCI_Cache := RCI_Locator_Table.Get (RCI_Package);
-
- if RCI_Cache = Empty then
- RCI_Locator :=
- RCI_Package_Locator
- (Loc, Specification (Unit_Declaration_Node (RCI_Package)));
- Prepend_To (Current_Sem_Unit_Declarations, RCI_Locator);
-
- -- The RCI_Locator package is inserted at the top level in the
- -- current unit, and must appear in the proper scope, so that it
- -- is not prematurely removed by the GCC back-end.
-
- declare
- Scop : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
-
- begin
- if Ekind (Scop) = E_Package_Body then
- Push_Scope (Spec_Entity (Scop));
-
- elsif Ekind (Scop) = E_Subprogram_Body then
- Push_Scope
- (Corresponding_Spec (Unit_Declaration_Node (Scop)));
+ RCI_Locator := RCI_Locator_Table.Get (RCI_Package);
- else
- Push_Scope (Scop);
- end if;
+ -- The RCI_Locator package and calling stub are is inserted at the
+ -- top level in the current unit, and must appear in the proper scope
+ -- so that it is not prematurely removed by the GCC back end.
- Analyze (RCI_Locator);
- Pop_Scope;
- end;
+ declare
+ Scop : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
+ begin
+ if Ekind (Scop) = E_Package_Body then
+ Push_Scope (Spec_Entity (Scop));
+ elsif Ekind (Scop) = E_Subprogram_Body then
+ Push_Scope
+ (Corresponding_Spec (Unit_Declaration_Node (Scop)));
+ else
+ Push_Scope (Scop);
+ end if;
+ end;
- RCI_Cache := Defining_Unit_Name (RCI_Locator);
+ if RCI_Locator = Empty then
+ RCI_Locator_Decl :=
+ RCI_Package_Locator
+ (Loc, Specification (Unit_Declaration_Node (RCI_Package)));
+ Prepend_To (Current_Sem_Unit_Declarations, RCI_Locator_Decl);
+ Analyze (RCI_Locator_Decl);
+ RCI_Locator := Defining_Unit_Name (RCI_Locator_Decl);
else
- RCI_Locator := Parent (RCI_Cache);
+ RCI_Locator_Decl := Parent (RCI_Locator);
end if;
Calling_Stubs := Build_Subprogram_Calling_Stubs
Asynchronous => Nkind (N) = N_Procedure_Call_Statement
and then
Is_Asynchronous (Called_Subprogram),
- Locator => RCI_Cache,
+ Locator => RCI_Locator,
New_Name => New_Internal_Name ('S'));
- Insert_After (RCI_Locator, Calling_Stubs);
+ Insert_After (RCI_Locator_Decl, Calling_Stubs);
Analyze (Calling_Stubs);
+ Pop_Scope;
+
E_Calling_Stubs := Defining_Unit_Name (Specification (Calling_Stubs));
end if;
procedure Expand_Calling_Stubs_Bodies (Unit_Node : Node_Id) is
Spec : constant Node_Id := Specification (Unit_Node);
- Decls : constant List_Id := Visible_Declarations (Spec);
begin
- Push_Scope (Scope_Of_Spec (Spec));
- Add_Calling_Stubs_To_Declarations
- (Specification (Unit_Node), Decls);
- Pop_Scope;
+ Add_Calling_Stubs_To_Declarations (Spec);
end Expand_Calling_Stubs_Bodies;
-----------------------------------
Remote_Statements : List_Id;
-- Various parts of the procedure
- Pnam : constant Entity_Id :=
- Make_Defining_Identifier
- (Loc, New_Internal_Name ('R'));
+ 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 :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
- Source_Receiver :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
- Source_Address :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
- Local_Stub :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('L'));
- Stubbed_Result :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
+ 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
Remote_Statements : List_Id;
Null_Statements : List_Id;
- Pnam : constant Entity_Id :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
+ Pnam : constant Entity_Id := Make_Temporary (Loc, 'R');
begin
Build_Stream_Procedure
Proc_Decls : List_Id;
Proc_Statements : List_Id;
- Origin : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- Chars => New_Internal_Name ('P'));
+ Origin : constant Entity_Id := Make_Temporary (Loc, 'P');
-- Additional local variables for the local case
- Proxy_Addr : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- Chars => New_Internal_Name ('P'));
+ Proxy_Addr : constant Entity_Id := Make_Temporary (Loc, 'P');
-- Additional local variables for the remote case
- Local_Stub : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- Chars => New_Internal_Name ('L'));
-
- Stub_Ptr : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- Chars => New_Internal_Name ('S'));
+ Local_Stub : constant Entity_Id := Make_Temporary (Loc, 'L');
+ Stub_Ptr : constant Entity_Id := Make_Temporary (Loc, 'S');
function Set_Field
(Field_Name : Name_Id;
Request_Parameter : Node_Id;
Pkg_RPC_Receiver : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- New_Internal_Name ('H'));
+ Make_Temporary (Loc, 'H');
Pkg_RPC_Receiver_Statements : List_Id;
Pkg_RPC_Receiver_Cases : constant List_Id := New_List;
Pkg_RPC_Receiver_Body : Node_Id;
-- A Pkg_RPC_Receiver is built to decode the request
- Lookup_RAS_Info : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- Chars => New_Internal_Name ('R'));
- -- A remote subprogram is created to allow peers to look up
- -- RAS information using subprogram ids.
+ Lookup_RAS : Node_Id;
+ Lookup_RAS_Info : constant Entity_Id := Make_Temporary (Loc, 'R');
+ -- A remote subprogram is created to allow peers to look up RAS
+ -- information using subprogram ids.
Subp_Id : Entity_Id;
Subp_Index : Entity_Id;
-- Subprogram_Id as read from the incoming stream
- Current_Declaration : Node_Id;
- Current_Subprogram_Number : Int := First_RCI_Subprogram_Id;
- Current_Stubs : Node_Id;
+ Current_Subp_Number : Int := First_RCI_Subprogram_Id;
+ Current_Stubs : Node_Id;
- Subp_Info_Array : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- Chars => New_Internal_Name ('I'));
-
- Subp_Info_List : constant List_Id := New_List;
+ Subp_Info_Array : constant Entity_Id := Make_Temporary (Loc, 'I');
+ Subp_Info_List : constant List_Id := New_List;
Register_Pkg_Actuals : constant List_Id := New_List;
-- associating Subprogram_Number with the subprogram declared
-- by Declaration, for which we have receiving stubs in Stubs.
+ procedure Visit_Subprogram (Decl : Node_Id);
+ -- Generate receiving stub for one remote subprogram
+
---------------------
-- Append_Stubs_To --
---------------------
New_Occurrence_Of (Request_Parameter, Loc))))));
end Append_Stubs_To;
+ ----------------------
+ -- Visit_Subprogram --
+ ----------------------
+
+ procedure Visit_Subprogram (Decl : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (Decl);
+ Spec : constant Node_Id := Specification (Decl);
+ Subp_Def : constant Entity_Id := Defining_Unit_Name (Spec);
+
+ Subp_Val : String_Id;
+ pragma Warnings (Off, Subp_Val);
+
+ begin
+ -- Build receiving stub
+
+ Current_Stubs :=
+ Build_Subprogram_Receiving_Stubs
+ (Vis_Decl => Decl,
+ Asynchronous =>
+ Nkind (Spec) = N_Procedure_Specification
+ and then Is_Asynchronous (Subp_Def));
+
+ Append_To (Decls, Current_Stubs);
+ Analyze (Current_Stubs);
+
+ -- Build RAS proxy
+
+ Add_RAS_Proxy_And_Analyze (Decls,
+ Vis_Decl => Decl,
+ All_Calls_Remote_E => All_Calls_Remote_E,
+ Proxy_Object_Addr => Proxy_Object_Addr);
+
+ -- Compute distribution identifier
+
+ Assign_Subprogram_Identifier
+ (Subp_Def, Current_Subp_Number, Subp_Val);
+
+ pragma Assert (Current_Subp_Number = Get_Subprogram_Id (Subp_Def));
+
+ -- Add subprogram descriptor (RCI_Subp_Info) to the subprograms
+ -- table for this receiver. This aggregate must be kept consistent
+ -- with the declaration of RCI_Subp_Info in
+ -- System.Partition_Interface.
+
+ Append_To (Subp_Info_List,
+ Make_Component_Association (Loc,
+ Choices => New_List (
+ Make_Integer_Literal (Loc, Current_Subp_Number)),
+
+ Expression =>
+ Make_Aggregate (Loc,
+ Component_Associations => New_List (
+
+ -- Addr =>
+
+ Make_Component_Association (Loc,
+ Choices =>
+ New_List (Make_Identifier (Loc, Name_Addr)),
+ Expression =>
+ New_Occurrence_Of (Proxy_Object_Addr, Loc))))));
+
+ Append_Stubs_To (Pkg_RPC_Receiver_Cases,
+ Stubs => Current_Stubs,
+ Subprogram_Number => Current_Subp_Number);
+
+ Current_Subp_Number := Current_Subp_Number + 1;
+ end Visit_Subprogram;
+
+ procedure Visit_Spec is new Build_Package_Stubs (Visit_Subprogram);
+
-- Start of processing for Add_Receiving_Stubs_To_Declarations
begin
Prefix => Request_Parameter,
Selector_Name => Name_Params))))),
- Selector_Name =>
- Make_Identifier (Loc, Name_Subp_Id))))));
+ Selector_Name => Make_Identifier (Loc, Name_Subp_Id))))));
-- Build a subprogram for RAS information lookups
- Current_Declaration :=
+ Lookup_RAS :=
Make_Subprogram_Declaration (Loc,
Specification =>
Make_Function_Specification (Loc,
New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc))),
Result_Definition =>
New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)));
-
- Append_To (Decls, Current_Declaration);
- Analyze (Current_Declaration);
+ Append_To (Decls, Lookup_RAS);
+ Analyze (Lookup_RAS);
Current_Stubs := Build_Subprogram_Receiving_Stubs
- (Vis_Decl => Current_Declaration,
+ (Vis_Decl => Lookup_RAS,
Asynchronous => False);
Append_To (Decls, Current_Stubs);
Analyze (Current_Stubs);
Append_Stubs_To (Pkg_RPC_Receiver_Cases,
- Stubs =>
- Current_Stubs,
+ Stubs => Current_Stubs,
Subprogram_Number => 1);
-- For each subprogram, the receiving stub will be built and a
Overload_Counter_Table.Reset;
- Current_Declaration := First (Visible_Declarations (Pkg_Spec));
- while Present (Current_Declaration) loop
- if Nkind (Current_Declaration) = N_Subprogram_Declaration
- and then Comes_From_Source (Current_Declaration)
- then
- declare
- Loc : constant Source_Ptr := Sloc (Current_Declaration);
- -- While specifically processing Current_Declaration, use
- -- its Sloc as the location of all generated nodes.
-
- Subp_Def : constant Entity_Id :=
- Defining_Unit_Name
- (Specification (Current_Declaration));
-
- Subp_Val : String_Id;
- pragma Warnings (Off, Subp_Val);
-
- begin
- -- Build receiving stub
-
- Current_Stubs :=
- Build_Subprogram_Receiving_Stubs
- (Vis_Decl => Current_Declaration,
- Asynchronous =>
- Nkind (Specification (Current_Declaration)) =
- N_Procedure_Specification
- and then Is_Asynchronous (Subp_Def));
-
- Append_To (Decls, Current_Stubs);
- Analyze (Current_Stubs);
-
- -- Build RAS proxy
-
- Add_RAS_Proxy_And_Analyze (Decls,
- Vis_Decl => Current_Declaration,
- All_Calls_Remote_E => All_Calls_Remote_E,
- Proxy_Object_Addr => Proxy_Object_Addr);
-
- -- Compute distribution identifier
-
- Assign_Subprogram_Identifier
- (Subp_Def,
- Current_Subprogram_Number,
- Subp_Val);
-
- pragma Assert
- (Current_Subprogram_Number = Get_Subprogram_Id (Subp_Def));
-
- -- Add subprogram descriptor (RCI_Subp_Info) to the
- -- subprograms table for this receiver. The aggregate
- -- below must be kept consistent with the declaration
- -- of type RCI_Subp_Info in System.Partition_Interface.
-
- Append_To (Subp_Info_List,
- Make_Component_Association (Loc,
- Choices => New_List (
- Make_Integer_Literal (Loc,
- Current_Subprogram_Number)),
-
- Expression =>
- Make_Aggregate (Loc,
- Component_Associations => New_List (
- Make_Component_Association (Loc,
- Choices => New_List (
- Make_Identifier (Loc, Name_Addr)),
- Expression =>
- New_Occurrence_Of (
- Proxy_Object_Addr, Loc))))));
-
- Append_Stubs_To (Pkg_RPC_Receiver_Cases,
- Stubs => Current_Stubs,
- Subprogram_Number => Current_Subprogram_Number);
- end;
-
- Current_Subprogram_Number := Current_Subprogram_Number + 1;
- end if;
-
- Next (Current_Declaration);
- end loop;
+ Visit_Spec (Pkg_Spec);
-- If we receive an invalid Subprogram_Id, it is best to do nothing
-- rather than raising an exception since we do not want someone
Loc : constant Source_Ptr := Sloc (Nod);
Stream_Parameter : Node_Id;
- -- Name of the stream used to transmit parameters to the
- -- remote package.
+ -- Name of the stream used to transmit parameters to the remote
+ -- package.
Result_Parameter : Node_Id;
-- Name of the result parameter (in non-APC cases) which get the
-- well as the declaration of Result. For a function call, 'Input is
-- always used to read the result even if it is constrained.
- Stream_Parameter :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
+ Stream_Parameter := Make_Temporary (Loc, 'S');
Append_To (Decls,
Make_Object_Declaration (Loc,
New_List (Make_Integer_Literal (Loc, 0))))));
if not Is_Known_Asynchronous then
- Result_Parameter :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
+ Result_Parameter := Make_Temporary (Loc, 'R');
Append_To (Decls,
Make_Object_Declaration (Loc,
Constraints =>
New_List (Make_Integer_Literal (Loc, 0))))));
- Exception_Return_Parameter :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
+ Exception_Return_Parameter := Make_Temporary (Loc, 'E');
Append_To (Decls,
Make_Object_Declaration (Loc,
-- type and push it in the stream after the regular
-- parameters.
- Extra_Parameter := Make_Defining_Identifier
- (Loc, New_Internal_Name ('P'));
+ Extra_Parameter := Make_Temporary (Loc, 'P');
Append_To (Decls,
Make_Object_Declaration (Loc,
else
-- Loop around parameters and assign out (or in out)
-- parameters. In the case of RACW, controlling arguments
- -- cannot possibly have changed since they are remote, so we do
- -- not read them from the stream.
+ -- cannot possibly have changed since they are remote, so
+ -- we do not read them from the stream.
Current_Parameter := First (Ordered_Parameters_List);
while Present (Current_Parameter) loop
(RPC_Receiver => RPC_Receiver,
Request_Parameter => Request);
- Subp_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
+ Subp_Id := Make_Temporary (Loc, 'P');
Subp_Index := Subp_Id;
-- Subp_Id may not be a constant, because in the case of the RPC
Controlling_Parameter : Entity_Id) return RPC_Target
is
Target_Info : RPC_Target (PCS_Kind => Name_GARLIC_DSA);
+
begin
- Target_Info.Partition :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
+ Target_Info.Partition := Make_Temporary (Loc, 'P');
+
if Present (Controlling_Parameter) then
Append_To (Decls,
Make_Object_Declaration (Loc,
procedure Build_Stub_Type
(RACW_Type : Entity_Id;
- Stub_Type : Entity_Id;
- Stub_Type_Decl : out Node_Id;
+ Stub_Type_Comps : out List_Id;
RPC_Receiver_Decl : out Node_Id)
is
- Loc : constant Source_Ptr := Sloc (Stub_Type);
+ Loc : constant Source_Ptr := Sloc (RACW_Type);
Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
begin
- Stub_Type_Decl :=
- Make_Full_Type_Declaration (Loc,
- Defining_Identifier => Stub_Type,
- Type_Definition =>
- Make_Record_Definition (Loc,
- Tagged_Present => True,
- Limited_Present => True,
- Component_List =>
- Make_Component_List (Loc,
- Component_Items => New_List (
-
- Make_Component_Declaration (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_Origin),
- Component_Definition =>
- Make_Component_Definition (Loc,
- Aliased_Present => False,
- Subtype_Indication =>
- New_Occurrence_Of (
- RTE (RE_Partition_ID), Loc))),
-
- Make_Component_Declaration (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_Receiver),
- Component_Definition =>
- Make_Component_Definition (Loc,
- Aliased_Present => False,
- Subtype_Indication =>
- New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))),
-
- Make_Component_Declaration (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_Addr),
- Component_Definition =>
- Make_Component_Definition (Loc,
- Aliased_Present => False,
- Subtype_Indication =>
- New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))),
-
- Make_Component_Declaration (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_Asynchronous),
- Component_Definition =>
- Make_Component_Definition (Loc,
- Aliased_Present => False,
- Subtype_Indication =>
- New_Occurrence_Of (
- Standard_Boolean, Loc)))))));
+ Stub_Type_Comps := New_List (
+ Make_Component_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_Origin),
+ Component_Definition =>
+ Make_Component_Definition (Loc,
+ Aliased_Present => False,
+ Subtype_Indication =>
+ New_Occurrence_Of (RTE (RE_Partition_ID), Loc))),
+
+ Make_Component_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_Receiver),
+ Component_Definition =>
+ Make_Component_Definition (Loc,
+ Aliased_Present => False,
+ Subtype_Indication =>
+ New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))),
+
+ Make_Component_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_Addr),
+ Component_Definition =>
+ Make_Component_Definition (Loc,
+ Aliased_Present => False,
+ Subtype_Indication =>
+ New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))),
+
+ Make_Component_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_Asynchronous),
+ Component_Definition =>
+ Make_Component_Definition (Loc,
+ Aliased_Present => False,
+ Subtype_Indication =>
+ New_Occurrence_Of (Standard_Boolean, Loc))));
if Is_RAS then
RPC_Receiver_Decl := Empty;
begin
RPC_Receiver_Decl :=
Make_Subprogram_Declaration (Loc,
- Build_RPC_Receiver_Specification (
- RPC_Receiver => Make_Defining_Identifier (Loc,
- New_Internal_Name ('R')),
- Request_Parameter => RPC_Receiver_Request));
+ Build_RPC_Receiver_Specification
+ (RPC_Receiver => Make_Temporary (Loc, 'R'),
+ Request_Parameter => RPC_Receiver_Request));
end;
end if;
end Build_Stub_Type;
is
Loc : constant Source_Ptr := Sloc (Vis_Decl);
- Request_Parameter : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- New_Internal_Name ('R'));
+ Request_Parameter : constant Entity_Id := Make_Temporary (Loc, 'R');
-- Formal parameter for receiving stubs: a descriptor for an incoming
-- request.
end if;
if Dynamically_Asynchronous then
- Dynamic_Async :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
+ Dynamic_Async := Make_Temporary (Loc, 'S');
else
Dynamic_Async := Empty;
end if;
Need_Extra_Constrained : Boolean;
-- True when an Extra_Constrained actual is required
- Object : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- New_Internal_Name ('P'));
+ Object : constant Entity_Id := Make_Temporary (Loc, 'P');
Expr : Node_Id := Empty;
declare
Etyp : constant Entity_Id :=
Etype (Result_Definition (Specification (Vis_Decl)));
- Result : constant Node_Id :=
- Make_Defining_Identifier (Loc,
- New_Internal_Name ('R'));
+ Result : constant Node_Id := Make_Temporary (Loc, 'R');
+
begin
Inner_Decls := New_List (
Make_Object_Declaration (Loc,
-- exception occurrence is copied into the output stream and
-- no other output parameter is written.
- Excep_Choice :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
+ Excep_Choice := Make_Temporary (Loc, 'E');
Excep_Code := New_List (
Make_Attribute_Reference (Loc,
Subp_Spec :=
Make_Procedure_Specification (Loc,
- Defining_Unit_Name =>
- Make_Defining_Identifier (Loc, New_Internal_Name ('F')),
+ Defining_Unit_Name => Make_Temporary (Loc, 'F'),
Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc,
-------------------------------
function Get_And_Reset_RACW_Bodies (RACW_Type : Entity_Id) return List_Id is
- Desig : constant Entity_Id := Etype (Designated_Type (RACW_Type));
+ Desig : constant Entity_Id :=
+ Etype (Designated_Type (RACW_Type));
+
Stub_Elements : Stub_Structure := Stubs_Table.Get (Desig);
Body_Decls : List_Id;
begin
return
Make_Subprogram_Body (Loc,
- Specification => Make_Function_Specification (Loc,
- Defining_Unit_Name =>
- Make_Defining_Identifier (Loc, New_Internal_Name ('S')),
- Result_Definition => New_Occurrence_Of (Var_Type, Loc)),
+ Specification =>
+ Make_Function_Specification (Loc,
+ Defining_Unit_Name => Make_Temporary (Loc, 'S'),
+ Result_Definition => New_Occurrence_Of (Var_Type, Loc)),
Declarations => No_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc, New_List (
Typ : Entity_Id;
begin
- -- If the kind of the parameter is E_Void, then it is not a
- -- controlling formal (this can happen in the context of RAS).
+ -- If the kind of the parameter is E_Void, then it is not a controlling
+ -- formal (this can happen in the context of RAS).
if Ekind (Defining_Identifier (Parameter)) = E_Void then
return False;
end if;
- -- If the parameter is not a controlling formal, then it cannot
- -- be possibly a RACW_Controlling_Formal.
+ -- If the parameter is not a controlling formal, then it cannot be
+ -- possibly a RACW_Controlling_Formal.
if not Is_Controlling_Formal (Defining_Identifier (Parameter)) then
return False;
--------------------
function Make_Tag_Check (Loc : Source_Ptr; N : Node_Id) return Node_Id is
- Occ : constant Entity_Id :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
+ Occ : constant Entity_Id := Make_Temporary (Loc, 'E');
begin
return Make_Block_Statement (Loc,
-- Name
Make_String_Literal (Loc,
- Full_Qualified_Name (Desig)),
+ Fully_Qualified_Name_String (Desig)),
-- Handler
is
Loc : constant Source_Ptr := Sloc (RACW_Type);
Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
-
Fnam : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Chars (RACW_Type), 'F'));
Statements : List_Id;
-- Various parts of the subprogram
- Any_Parameter : constant Entity_Id :=
- Make_Defining_Identifier (Loc, Name_A);
+ Any_Parameter : constant Entity_Id :=
+ Make_Defining_Identifier (Loc, Name_A);
Asynchronous_Flag : constant Entity_Id :=
Asynchronous_Flags_Table.Get (RACW_Type);
Make_Defining_Identifier (Loc, Name_R);
-- Various parts of the procedure
- Pnam : constant Entity_Id := Make_Defining_Identifier (Loc,
- New_Internal_Name ('R'));
+ Pnam : constant Entity_Id := Make_Temporary (Loc, 'R');
Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
Func_Decl : Node_Id;
Func_Body : Node_Id;
- Decls : List_Id;
- Statements : List_Id;
+ Decls : List_Id;
+ Statements : List_Id;
-- Various parts of the subprogram
RACW_Parameter : constant Entity_Id :=
Make_Defining_Identifier (Loc, Name_R);
- Reference : constant Entity_Id :=
- Make_Defining_Identifier
- (Loc, New_Internal_Name ('R'));
- Any : constant Entity_Id :=
- Make_Defining_Identifier
- (Loc, New_Internal_Name ('A'));
+ Reference : constant Entity_Id := Make_Temporary (Loc, 'R');
+ Any : constant Entity_Id := Make_Temporary (Loc, 'A');
begin
Func_Spec :=
Unchecked_Convert_To (RTE (RE_Address),
New_Occurrence_Of (RACW_Parameter, Loc)),
Make_String_Literal (Loc,
- Strval => Full_Qualified_Name
+ Strval => Fully_Qualified_Name_String
(Etype (Designated_Type (RACW_Type)))),
Build_Stub_Tag (Loc, RACW_Type),
New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc),
Func_Body : Node_Id;
begin
-
-- The spec for this subprogram has a dummy 'access RACW' argument,
-- which serves only for overloading purposes.
Attr_Decl : Node_Id;
Statements : constant List_Id := New_List;
- Pnam : constant Entity_Id :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
+ Pnam : constant Entity_Id := Make_Temporary (Loc, 'R');
function Stream_Parameter return Node_Id;
function Object return Node_Id;
Parameter_Associations => New_List (
Unchecked_Convert_To (RTE (RE_Address), Object),
Make_String_Literal (Loc,
- Strval => Full_Qualified_Name
+ Strval => Fully_Qualified_Name_String
(Etype (Designated_Type (RACW_Type)))),
Build_Stub_Tag (Loc, RACW_Type),
New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc),
Make_Defining_Identifier (Loc, Name_A);
-- For the call to Get_Local_Address
+ Local_Stub : constant Entity_Id := Make_Temporary (Loc, 'L');
+ Stub_Ptr : constant Entity_Id := Make_Temporary (Loc, 'S');
-- Additional local variables for the remote case
- Local_Stub : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- Chars => New_Internal_Name ('L'));
-
- Stub_Ptr : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- Chars => New_Internal_Name ('S'));
-
function Set_Field
(Field_Name : Name_Id;
Value : Node_Id) return Node_Id;
Append_To (Proc_Statements,
- -- if L then
+ -- if L then
Make_Implicit_If_Statement (N,
Condition => New_Occurrence_Of (Is_Local, Loc),
Then_Statements => New_List (
- -- if A.Target = null then
+ -- if A.Target = null then
Make_Implicit_If_Statement (N,
Condition =>
Then_Statements => New_List (
- -- A.Target := Entity_Of (Ref);
+ -- A.Target := Entity_Of (Ref);
Make_Assignment_Statement (Loc,
Name =>
Parameter_Associations => New_List (
New_Occurrence_Of (Subp_Ref, Loc)))),
- -- Inc_Usage (A.Target);
+ -- Inc_Usage (A.Target);
+ -- end if;
Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (RTE (RE_Inc_Usage), Loc),
Selector_Name =>
Make_Identifier (Loc, Name_Target)))))),
- -- end if;
- -- if not All_Calls_Remote then
- -- return Fat_Type!(A);
- -- end if;
+ -- if not All_Calls_Remote then
+ -- return Fat_Type!(A);
+ -- end if;
Make_Implicit_If_Statement (N,
Condition =>
Append_List_To (Proc_Statements, New_List (
- -- Stub.Target := Entity_Of (Ref);
+ -- Stub.Target := Entity_Of (Ref);
Set_Field (Name_Target,
Make_Function_Call (Loc,
Parameter_Associations => New_List (
New_Occurrence_Of (Subp_Ref, Loc)))),
- -- Inc_Usage (Stub.Target);
+ -- Inc_Usage (Stub.Target);
Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (RTE (RE_Inc_Usage), Loc),
Prefix => Stub_Ptr,
Selector_Name => Name_Target))),
- -- E.4.1(9) A remote call is asynchronous if it is a call to
- -- a procedure, or a call through a value of an access-to-procedure
- -- type, to which a pragma Asynchronous applies.
+ -- E.4.1(9) A remote call is asynchronous if it is a call to
+ -- a procedure, or a call through a value of an access-to-procedure
+ -- type, to which a pragma Asynchronous applies.
- -- Parameter Asynch_P is true when the procedure is asynchronous;
- -- Expression Asynch_T is true when the type is asynchronous.
+ -- Parameter Asynch_P is true when the procedure is asynchronous;
+ -- Expression Asynch_T is true when the type is asynchronous.
Set_Field (Name_Asynchronous,
Make_Or_Else (Loc,
Make_Aggregate (Loc,
Component_Associations => New_List (
Make_Component_Association (Loc,
- Choices => New_List (
- Make_Identifier (Loc, Name_Ras)),
+ Choices => New_List (Make_Identifier (Loc, Name_Ras)),
Expression =>
PolyORB_Support.Helpers.Build_From_Any_Call (
Underlying_RACW_Type (RAS_Type),
Func_Spec : Node_Id;
- Any : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- Chars => New_Internal_Name ('A'));
- RAS_Parameter : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- Chars => New_Internal_Name ('R'));
+ Any : constant Entity_Id := Make_Temporary (Loc, 'A');
+ RAS_Parameter : constant Entity_Id := Make_Temporary (Loc, 'R');
RACW_Parameter : constant Node_Id :=
Make_Selected_Component (Loc,
Prefix => RAS_Parameter,
Loc : constant Source_Ptr := Sloc (Pkg_Spec);
Pkg_RPC_Receiver : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- New_Internal_Name ('H'));
+ Make_Temporary (Loc, 'H');
Pkg_RPC_Receiver_Object : Node_Id;
Pkg_RPC_Receiver_Body : Node_Id;
Pkg_RPC_Receiver_Decls : List_Id;
-- Request object received from neutral layer
Subp_Id : Entity_Id;
- -- Subprogram identifier as received from the neutral
- -- distribution core.
+ -- Subprogram identifier as received from the neutral distribution
+ -- core.
Subp_Index : Entity_Id;
-- Internal index as determined by matching either the method name
-- from the request structure, or the local subprogram address (in
-- case of a RAS).
- Is_Local : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- Chars => New_Internal_Name ('L'));
+ Is_Local : constant Entity_Id := Make_Temporary (Loc, 'L');
- Local_Address : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- Chars => New_Internal_Name ('A'));
+ Local_Address : constant Entity_Id := Make_Temporary (Loc, 'A');
-- Address of a local subprogram designated by a reference
-- corresponding to a RAS.
Dispatch_On_Address : constant List_Id := New_List;
Dispatch_On_Name : constant List_Id := New_List;
- Current_Declaration : Node_Id;
- Current_Stubs : Node_Id;
- Current_Subprogram_Number : Int := First_RCI_Subprogram_Id;
+ Current_Subp_Number : Int := First_RCI_Subprogram_Id;
- Subp_Info_Array : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- Chars => New_Internal_Name ('I'));
-
- Subp_Info_List : constant List_Id := New_List;
+ Subp_Info_Array : constant Entity_Id := Make_Temporary (Loc, 'I');
+ Subp_Info_List : constant List_Id := New_List;
Register_Pkg_Actuals : constant List_Id := New_List;
-- object, used in the context of calls through remote
-- access-to-subprogram types.
+ procedure Visit_Subprogram (Decl : Node_Id);
+ -- Generate receiving stub for one remote subprogram
+
---------------------
-- Append_Stubs_To --
---------------------
Make_Integer_Literal (Loc, Subp_Number)))));
end Append_Stubs_To;
+ ----------------------
+ -- Visit_Subprogram --
+ ----------------------
+
+ procedure Visit_Subprogram (Decl : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (Decl);
+ Spec : constant Node_Id := Specification (Decl);
+ Subp_Def : constant Entity_Id := Defining_Unit_Name (Spec);
+
+ Subp_Val : String_Id;
+
+ Subp_Dist_Name : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars =>
+ New_External_Name
+ (Related_Id => Chars (Subp_Def),
+ Suffix => 'D',
+ Suffix_Index => -1));
+
+ Current_Stubs : Node_Id;
+ Proxy_Obj_Addr : Entity_Id;
+
+ begin
+ -- Build receiving stub
+
+ Current_Stubs :=
+ Build_Subprogram_Receiving_Stubs
+ (Vis_Decl => Decl,
+ Asynchronous => Nkind (Spec) = N_Procedure_Specification
+ and then Is_Asynchronous (Subp_Def));
+
+ Append_To (Decls, Current_Stubs);
+ Analyze (Current_Stubs);
+
+ -- Build RAS proxy
+
+ Add_RAS_Proxy_And_Analyze (Decls,
+ Vis_Decl => Decl,
+ All_Calls_Remote_E => All_Calls_Remote_E,
+ Proxy_Object_Addr => Proxy_Obj_Addr);
+
+ -- Compute distribution identifier
+
+ Assign_Subprogram_Identifier
+ (Subp_Def, Current_Subp_Number, Subp_Val);
+
+ pragma Assert
+ (Current_Subp_Number = Get_Subprogram_Id (Subp_Def));
+
+ Append_To (Decls,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Subp_Dist_Name,
+ Constant_Present => True,
+ Object_Definition =>
+ New_Occurrence_Of (Standard_String, Loc),
+ Expression =>
+ Make_String_Literal (Loc, Subp_Val)));
+ Analyze (Last (Decls));
+
+ -- Add subprogram descriptor (RCI_Subp_Info) to the subprograms
+ -- table for this receiver. The aggregate below must be kept
+ -- consistent with the declaration of RCI_Subp_Info in
+ -- System.Partition_Interface.
+
+ Append_To (Subp_Info_List,
+ Make_Component_Association (Loc,
+ Choices =>
+ New_List (Make_Integer_Literal (Loc, Current_Subp_Number)),
+
+ Expression =>
+ Make_Aggregate (Loc,
+ Expressions => New_List (
+
+ -- Name =>
+
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Subp_Dist_Name, Loc),
+ Attribute_Name => Name_Address),
+
+ -- Name_Length =>
+
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Subp_Dist_Name, Loc),
+ Attribute_Name => Name_Length),
+
+ -- Addr =>
+
+ New_Occurrence_Of (Proxy_Obj_Addr, Loc)))));
+
+ Append_Stubs_To (Pkg_RPC_Receiver_Cases,
+ Declaration => Decl,
+ Stubs => Current_Stubs,
+ Subp_Number => Current_Subp_Number,
+ Subp_Dist_Name => Subp_Dist_Name,
+ Subp_Proxy_Addr => Proxy_Obj_Addr);
+
+ Current_Subp_Number := Current_Subp_Number + 1;
+ end Visit_Subprogram;
+
+ procedure Visit_Spec is new Build_Package_Stubs (Visit_Subprogram);
+
-- Start of processing for Add_Receiving_Stubs_To_Declarations
begin
-- Building receiving stubs consist in several operations:
- -- - a package RPC receiver must be built. This subprogram
- -- will get a Subprogram_Id from the incoming stream
- -- and will dispatch the call to the right subprogram;
+ -- - a package RPC receiver must be built. This subprogram will get
+ -- a Subprogram_Id from the incoming stream and will dispatch the
+ -- call to the right subprogram;
-- - a receiving stub for 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,
New_Occurrence_Of (Is_Local, Loc),
New_Occurrence_Of (Local_Address, Loc))));
- -- For each subprogram, the receiving stub will be built and a
- -- case statement will be made on the Subprogram_Id to dispatch
- -- to the right subprogram.
+ -- For each subprogram, the receiving stub will be built and a case
+ -- statement will be made on the Subprogram_Id to dispatch to the
+ -- right subprogram.
All_Calls_Remote_E := Boolean_Literals (
Has_All_Calls_Remote (Defining_Entity (Pkg_Spec)));
Overload_Counter_Table.Reset;
Reserve_NamingContext_Methods;
- Current_Declaration := First (Visible_Declarations (Pkg_Spec));
- while Present (Current_Declaration) loop
- if Nkind (Current_Declaration) = N_Subprogram_Declaration
- and then Comes_From_Source (Current_Declaration)
- then
- declare
- Loc : constant Source_Ptr := Sloc (Current_Declaration);
- -- While specifically processing Current_Declaration, use
- -- its Sloc as the location of all generated nodes.
-
- Subp_Def : constant Entity_Id :=
- Defining_Unit_Name
- (Specification (Current_Declaration));
-
- Subp_Val : String_Id;
-
- Subp_Dist_Name : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- Chars =>
- New_External_Name
- (Related_Id => Chars (Subp_Def),
- Suffix => 'D',
- Suffix_Index => -1));
-
- Proxy_Object_Addr : Entity_Id;
-
- begin
- -- Build receiving stub
-
- Current_Stubs :=
- Build_Subprogram_Receiving_Stubs
- (Vis_Decl => Current_Declaration,
- Asynchronous =>
- Nkind (Specification (Current_Declaration)) =
- N_Procedure_Specification
- and then Is_Asynchronous (Subp_Def));
-
- Append_To (Decls, Current_Stubs);
- Analyze (Current_Stubs);
-
- -- Build RAS proxy
-
- Add_RAS_Proxy_And_Analyze (Decls,
- Vis_Decl => Current_Declaration,
- All_Calls_Remote_E => All_Calls_Remote_E,
- Proxy_Object_Addr => Proxy_Object_Addr);
-
- -- Compute distribution identifier
-
- Assign_Subprogram_Identifier
- (Subp_Def,
- Current_Subprogram_Number,
- Subp_Val);
-
- pragma Assert
- (Current_Subprogram_Number = Get_Subprogram_Id (Subp_Def));
-
- Append_To (Decls,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Subp_Dist_Name,
- Constant_Present => True,
- Object_Definition =>
- New_Occurrence_Of (Standard_String, Loc),
- Expression =>
- Make_String_Literal (Loc, Subp_Val)));
- Analyze (Last (Decls));
-
- -- Add subprogram descriptor (RCI_Subp_Info) to the
- -- subprograms table for this receiver. The aggregate
- -- below must be kept consistent with the declaration
- -- of type RCI_Subp_Info in System.Partition_Interface.
-
- Append_To (Subp_Info_List,
- Make_Component_Association (Loc,
- Choices => New_List (
- Make_Integer_Literal (Loc, Current_Subprogram_Number)),
-
- Expression =>
- Make_Aggregate (Loc,
- Expressions => New_List (
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (Subp_Dist_Name, Loc),
- Attribute_Name => Name_Address),
-
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (Subp_Dist_Name, Loc),
- Attribute_Name => Name_Length),
-
- New_Occurrence_Of (Proxy_Object_Addr, Loc)))));
-
- Append_Stubs_To (Pkg_RPC_Receiver_Cases,
- Declaration => Current_Declaration,
- Stubs => Current_Stubs,
- Subp_Number => Current_Subprogram_Number,
- Subp_Dist_Name => Subp_Dist_Name,
- Subp_Proxy_Addr => Proxy_Object_Addr);
- end;
-
- Current_Subprogram_Number := Current_Subprogram_Number + 1;
- end if;
-
- Next (Current_Declaration);
- end loop;
+ Visit_Spec (Pkg_Spec);
Append_To (Decls,
Make_Object_Declaration (Loc,
Pkg_RPC_Receiver_Object :=
Make_Object_Declaration (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, New_Internal_Name ('R')),
+ Defining_Identifier => Make_Temporary (Loc, 'R'),
Aliased_Present => True,
Object_Definition => New_Occurrence_Of (RTE (RE_Servant), Loc));
Append_To (Decls, Pkg_RPC_Receiver_Object);
Append_To (Register_Pkg_Actuals,
New_Occurrence_Of (All_Calls_Remote_E, Loc));
- -- ???
+ -- Finally call Register_Pkg_Receiving_Stub with the above parameters
Append_To (Stmts,
Make_Procedure_Call_Statement (Loc,
is
Loc : constant Source_Ptr := Sloc (Nod);
- Request : constant Entity_Id :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
+ Request : constant Entity_Id := Make_Temporary (Loc, 'R');
-- The request object constructed by these stubs
-- Could we use Name_R instead??? (see GLADE client stubs)
(RE : RE_Id;
Actuals : List_Id := New_List) return Node_Id;
-- Generate a procedure call statement calling RE with the given
- -- actuals. Request is appended to the list.
+ -- actuals. Request'Access is appended to the list.
---------------------------
-- Make_Request_RTE_Call --
Actuals : List_Id := New_List) return Node_Id
is
begin
- Append_To (Actuals, New_Occurrence_Of (Request, Loc));
+ Append_To (Actuals,
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Request, Loc),
+ Attribute_Name => Name_Access));
return Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTE (RE), Loc),
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => Request,
- Aliased_Present => False,
+ Aliased_Present => True,
Object_Definition =>
- New_Occurrence_Of (RTE (RE_Request_Access), Loc)));
+ New_Occurrence_Of (RTE (RE_Request), Loc)));
- Result :=
- Make_Defining_Identifier (Loc,
- Chars => New_Internal_Name ('R'));
+ Result := Make_Temporary (Loc, 'R');
if Is_Function then
Result_TC :=
Expression => Make_Integer_Literal (Loc, 0))))));
if not Is_Known_Asynchronous then
- Exception_Return_Parameter :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
+ Exception_Return_Parameter := Make_Temporary (Loc, 'E');
Append_To (Decls,
Make_Object_Declaration (Loc,
-- Initialize and fill in arguments list
- Arguments :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
+ Arguments := Make_Temporary (Loc, 'A');
Declare_Create_NVList (Loc, Arguments, Decls, Statements);
Current_Parameter := First (Ordered_Parameters_List);
Is_Constrained (Etyp)
or else Is_Elementary_Type (Etyp);
- Any : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- New_Internal_Name ('A'));
+ Any : constant Entity_Id := Make_Temporary (Loc, 'A');
Actual_Parameter : Node_Id :=
New_Occurrence_Of (
if Out_Present (Current_Parameter)
and then not Is_Controlling_Formal
then
- Append_To (After_Statements,
- Make_Assignment_Statement (Loc,
- Name =>
- New_Occurrence_Of (
- Defining_Identifier (Current_Parameter), Loc),
- Expression =>
- PolyORB_Support.Helpers.Build_From_Any_Call
- (Etype (Parameter_Type (Current_Parameter)),
- New_Occurrence_Of (Any, Loc),
- Decls)));
-
+ if Is_Limited_Type (Etyp) then
+ Helpers.Assign_Opaque_From_Any (Loc,
+ Stms => After_Statements,
+ Typ => Etyp,
+ N => New_Occurrence_Of (Any, Loc),
+ Target =>
+ Defining_Identifier (Current_Parameter));
+ else
+ Append_To (After_Statements,
+ Make_Assignment_Statement (Loc,
+ Name =>
+ New_Occurrence_Of (
+ Defining_Identifier (Current_Parameter), Loc),
+ Expression =>
+ PolyORB_Support.Helpers.Build_From_Any_Call
+ (Etyp,
+ New_Occurrence_Of (Any, Loc),
+ Decls)));
+ end if;
end if;
end;
end if;
declare
Extra_Any_Parameter : constant Entity_Id :=
- Make_Defining_Identifier
- (Loc, New_Internal_Name ('P'));
+ Make_Temporary (Loc, 'P');
Parameter_Exp : constant Node_Id :=
Make_Attribute_Reference (Loc,
Append_List_To (Statements, Extra_Formal_Statements);
Append_To (Statements,
- Make_Request_RTE_Call (RE_Request_Create, New_List (
- Target_Object,
- Subprogram_Id,
- New_Occurrence_Of (Arguments, Loc),
- New_Occurrence_Of (Result, Loc),
- New_Occurrence_Of
- (RTE (RE_Nil_Exc_List), Loc))));
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Occurrence_Of (RTE (RE_Request_Setup), Loc),
+ Parameter_Associations => New_List (
+ New_Occurrence_Of (Request, Loc),
+ Target_Object,
+ Subprogram_Id,
+ New_Occurrence_Of (Arguments, Loc),
+ New_Occurrence_Of (Result, Loc),
+ New_Occurrence_Of (RTE (RE_Nil_Exc_List), Loc))));
pragma Assert
(not (Is_Known_Non_Asynchronous and Is_Known_Asynchronous));
-- Asynchronous case
if not Is_Known_Non_Asynchronous then
- Asynchronous_Statements :=
- New_List (Make_Request_RTE_Call (RE_Request_Destroy));
+ Asynchronous_Statements := New_List (Make_Null_Statement (Loc));
end if;
-- Non-asynchronous case
New_Occurrence_Of (Request, Loc))));
if Is_Function then
-
- Append_To (Non_Asynchronous_Statements,
- Make_Request_RTE_Call (RE_Request_Destroy));
-
-- If this is a function call, read the value and return it
Append_To (Non_Asynchronous_Statements,
-- Case of a procedure: deal with IN OUT and OUT formals
Append_List_To (Non_Asynchronous_Statements, After_Statements);
-
- Append_To (Non_Asynchronous_Statements,
- Make_Request_RTE_Call (RE_Request_Destroy));
end if;
end if;
Controlling_Parameter : Entity_Id) return RPC_Target
is
Target_Info : RPC_Target (PCS_Kind => Name_PolyORB_DSA);
- Target_Reference : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- New_Internal_Name ('T'));
+ Target_Reference : constant Entity_Id := Make_Temporary (Loc, 'T');
+
begin
if Present (Controlling_Parameter) then
Append_To (Decls,
else
Target_Info.Object :=
Make_Selected_Component (Loc,
- Prefix => Make_Identifier (Loc, Chars (RCI_Locator)),
+ Prefix =>
+ Make_Identifier (Loc, Chars (RCI_Locator)),
Selector_Name =>
Make_Identifier (Loc, Name_Get_RCI_Package_Ref));
end if;
procedure Build_Stub_Type
(RACW_Type : Entity_Id;
- Stub_Type : Entity_Id;
- Stub_Type_Decl : out Node_Id;
+ Stub_Type_Comps : out List_Id;
RPC_Receiver_Decl : out Node_Id)
is
- Loc : constant Source_Ptr := Sloc (Stub_Type);
-
- pragma Unreferenced (RACW_Type);
+ Loc : constant Source_Ptr := Sloc (RACW_Type);
begin
- Stub_Type_Decl :=
- Make_Full_Type_Declaration (Loc,
- Defining_Identifier => Stub_Type,
- Type_Definition =>
- Make_Record_Definition (Loc,
- Tagged_Present => True,
- Limited_Present => True,
- Component_List =>
- Make_Component_List (Loc,
- Component_Items => New_List (
-
- Make_Component_Declaration (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_Target),
- Component_Definition =>
- Make_Component_Definition (Loc,
- Aliased_Present => False,
- Subtype_Indication =>
- New_Occurrence_Of (RTE (RE_Entity_Ptr), Loc))),
-
- Make_Component_Declaration (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_Asynchronous),
-
- Component_Definition =>
- Make_Component_Definition (Loc,
- Aliased_Present => False,
- Subtype_Indication =>
- New_Occurrence_Of (Standard_Boolean, Loc)))))));
+ Stub_Type_Comps := New_List (
+ Make_Component_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_Target),
+ Component_Definition =>
+ Make_Component_Definition (Loc,
+ Aliased_Present => False,
+ Subtype_Indication =>
+ New_Occurrence_Of (RTE (RE_Entity_Ptr), Loc))),
+
+ Make_Component_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_Asynchronous),
+
+ Component_Definition =>
+ Make_Component_Definition (Loc,
+ Aliased_Present => False,
+ Subtype_Indication =>
+ New_Occurrence_Of (Standard_Boolean, Loc))));
RPC_Receiver_Decl :=
Make_Object_Declaration (Loc,
- Defining_Identifier => Make_Defining_Identifier (Loc,
- New_Internal_Name ('R')),
+ Defining_Identifier => Make_Temporary (Loc, 'R'),
Aliased_Present => True,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Servant), Loc));
is
Loc : constant Source_Ptr := Sloc (Vis_Decl);
- Request_Parameter : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- New_Internal_Name ('R'));
+ Request_Parameter : constant Entity_Id := Make_Temporary (Loc, 'R');
-- Formal parameter for receiving stubs: a descriptor for an incoming
-- request.
Decls : constant List_Id := New_List;
-- All the parameters will get declared before calling the real
- -- subprograms. Also the out parameters will be declared.
- -- At this level, parameters may be unconstrained.
+ -- subprograms. Also the out parameters will be declared. At this
+ -- level, parameters may be unconstrained.
Statements : constant List_Id := New_List;
Build_Ordered_Parameters_List
(Specification (Vis_Decl));
- Arguments : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- New_Internal_Name ('A'));
+ Arguments : constant Entity_Id := Make_Temporary (Loc, 'A');
-- Name of the named values list used to retrieve parameters
Subp_Spec : Node_Id;
declare
Etyp : Entity_Id;
Constrained : Boolean;
- Any : Entity_Id := Empty;
- Object : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- Chars => New_Internal_Name ('P'));
- Expr : Node_Id := Empty;
+ Any : Entity_Id := Empty;
+ Object : constant Entity_Id := Make_Temporary (Loc, 'P');
+ Expr : Node_Id := Empty;
Is_Controlling_Formal : constant Boolean :=
Is_RACW_Controlling_Formal
-- Controlling formals in distributed object primitive
-- operations are handled specially:
+
-- - the first controlling formal is used as the
-- target of the call;
+
-- - the remaining controlling formals are transmitted
-- as RACWs.
Is_Constrained (Etyp) or else Is_Elementary_Type (Etyp);
if not Is_First_Controlling_Formal then
- Any :=
- Make_Defining_Identifier (Loc,
- Chars => New_Internal_Name ('A'));
+ Any := Make_Temporary (Loc, 'A');
Append_To (Outer_Decls,
Make_Object_Declaration (Loc,
if Is_First_Controlling_Formal then
declare
- Addr : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- Chars => New_Internal_Name ('A'));
+ Addr : constant Entity_Id := Make_Temporary (Loc, 'A');
Is_Local : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- Chars => New_Internal_Name ('L'));
+ Make_Temporary (Loc, 'L');
begin
-- Special case: obtain the first controlling formal
New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc),
Parameter_Associations => New_List (
Make_Selected_Component (Loc,
- Prefix =>
+ Prefix =>
New_Occurrence_Of (
Request_Parameter, Loc),
Selector_Name =>
-- the object declaration and the variable is set using
-- 'Input instead of 'Read.
- Expr := PolyORB_Support.Helpers.Build_From_Any_Call (
- Etyp, New_Occurrence_Of (Any, Loc), Decls);
+ if Constrained and then Is_Limited_Type (Etyp) then
+ Helpers.Assign_Opaque_From_Any (Loc,
+ Stms => Statements,
+ Typ => Etyp,
+ N => New_Occurrence_Of (Any, Loc),
+ Target => Object);
- if Constrained then
- Append_To (Statements,
- Make_Assignment_Statement (Loc,
- Name => New_Occurrence_Of (Object, Loc),
- Expression => Expr));
- Expr := Empty;
else
- null;
+ Expr := Helpers.Build_From_Any_Call
+ (Etyp, New_Occurrence_Of (Any, Loc), Decls);
- -- Expr will be used to initialize (and constrain) the
- -- parameter when it is declared.
- end if;
+ if Constrained then
+ Append_To (Statements,
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Object, Loc),
+ Expression => Expr));
+ Expr := Empty;
+ else
+ -- Expr will be used to initialize (and constrain) the
+ -- parameter when it is declared.
+ null;
+ end if;
+
+ null;
+ end if;
end if;
Need_Extra_Constrained :=
(Defining_Identifier (Current_Parameter), Loc),
Explicit_Actual_Parameter =>
Make_Explicit_Dereference (Loc,
- Prefix =>
- Unchecked_Convert_To (RACW_Type,
- OK_Convert_To (RTE (RE_Address),
- New_Occurrence_Of (Object, Loc))))));
+ Prefix => New_Occurrence_Of (Object, Loc))));
else
Append_To (Parameter_List,
(Defining_Identifier (Current_Parameter), Loc),
Explicit_Actual_Parameter =>
- Unchecked_Convert_To (RACW_Type,
- OK_Convert_To (RTE (RE_Address),
- New_Occurrence_Of (Object, Loc)))));
+ New_Occurrence_Of (Object, Loc)));
end if;
else
(Current_Parameter));
Extra_Any : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- Chars => New_Internal_Name ('A'));
+ Make_Temporary (Loc, 'A');
Formal_Entity : constant Entity_Id :=
Make_Defining_Identifier (Loc,
declare
Etyp : constant Entity_Id :=
Etype (Result_Definition (Specification (Vis_Decl)));
- Result : constant Node_Id :=
- Make_Defining_Identifier (Loc,
- Chars => New_Internal_Name ('R'));
+ Result : constant Node_Id := Make_Temporary (Loc, 'R');
begin
Inner_Decls := New_List (
Subp_Spec :=
Make_Procedure_Specification (Loc,
- Defining_Unit_Name =>
- Make_Defining_Identifier (Loc, New_Internal_Name ('F')),
+ Defining_Unit_Name => Make_Temporary (Loc, 'F'),
Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc,
Parameter_Type =>
New_Occurrence_Of (RTE (RE_Request_Access), Loc))));
- -- An exception raised during the execution of an incoming
- -- remote subprogram call and that needs to be sent back
- -- to the caller is propagated by the receiving stubs, and
- -- will be handled by the caller (the distribution runtime).
+ -- An exception raised during the execution of an incoming remote
+ -- subprogram call and that needs to be sent back to the caller is
+ -- propagated by the receiving stubs, and will be handled by the
+ -- caller (the distribution runtime).
if Asynchronous and then not Dynamically_Asynchronous then
Arry : Entity_Id;
-- For 'Range and Etype
- Indices : List_Id;
+ Indexes : List_Id;
-- For the construction of the innermost element expression
with procedure Add_Process_Element
Depth : Pos := 1);
-- Build nested loop statements that iterate over the elements of an
-- array Arry. The statement(s) built by Add_Process_Element are
- -- executed for each element; Indices is the list of indices to be
+ -- executed for each element; Indexes is the list of indexes to be
-- used in the construction of the indexed component that denotes the
-- current element. Subprogram is the entity for the subprogram for
-- which this iterator is generated. The generated statements are
end if;
end Append_Record_Traversal;
+ -----------------------------
+ -- Assign_Opaque_From_Any --
+ -----------------------------
+
+ procedure Assign_Opaque_From_Any
+ (Loc : Source_Ptr;
+ Stms : List_Id;
+ Typ : Entity_Id;
+ N : Node_Id;
+ Target : Entity_Id)
+ is
+ Strm : constant Entity_Id := Make_Temporary (Loc, 'S');
+ Expr : Node_Id;
+
+ Read_Call_List : List_Id;
+ -- List on which to place the 'Read attribute reference
+
+ begin
+ -- Strm : Buffer_Stream_Type;
+
+ Append_To (Stms,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Strm,
+ Aliased_Present => True,
+ Object_Definition =>
+ New_Occurrence_Of (RTE (RE_Buffer_Stream_Type), Loc)));
+
+ -- Any_To_BS (Strm, A);
+
+ Append_To (Stms,
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Occurrence_Of (RTE (RE_Any_To_BS), Loc),
+ Parameter_Associations => New_List (
+ N,
+ New_Occurrence_Of (Strm, Loc))));
+
+ if Transmit_As_Unconstrained (Typ) then
+ Expr :=
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Typ, Loc),
+ Attribute_Name => Name_Input,
+ Expressions => New_List (
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Strm, Loc),
+ Attribute_Name => Name_Access)));
+
+ -- Target := Typ'Input (Strm'Access)
+
+ if Present (Target) then
+ Append_To (Stms,
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Target, Loc),
+ Expression => Expr));
+
+ -- return Typ'Input (Strm'Access);
+
+ else
+ Append_To (Stms,
+ Make_Simple_Return_Statement (Loc,
+ Expression => Expr));
+ end if;
+
+ else
+ if Present (Target) then
+ Read_Call_List := Stms;
+ Expr := New_Occurrence_Of (Target, Loc);
+
+ else
+ declare
+ Temp : constant Entity_Id := Make_Temporary (Loc, 'R');
+
+ begin
+ Read_Call_List := New_List;
+ Expr := New_Occurrence_Of (Temp, Loc);
+
+ Append_To (Stms, Make_Block_Statement (Loc,
+ Declarations => New_List (
+ Make_Object_Declaration (Loc,
+ Defining_Identifier =>
+ Temp,
+ Object_Definition =>
+ New_Occurrence_Of (Typ, Loc))),
+
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => Read_Call_List)));
+ end;
+ end if;
+
+ -- Typ'Read (Strm'Access, [Target|Temp])
+
+ Append_To (Read_Call_List,
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Typ, Loc),
+ Attribute_Name => Name_Read,
+ Expressions => New_List (
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Strm, Loc),
+ Attribute_Name => Name_Access),
+ Expr)));
+
+ if No (Target) then
+
+ -- return Temp
+
+ Append_To (Read_Call_List,
+ Make_Simple_Return_Statement (Loc,
+ Expression => New_Copy (Expr)));
+ end if;
+ end if;
+ end Assign_Opaque_From_Any;
+
-------------------------
-- Build_From_Any_Call --
-------------------------
Fnam := Find_Inherited_TSS (U_Type, TSS_From_Any);
+ -- For the subtype representing a generic actual type, go to the
+ -- actual type.
+
+ if Is_Generic_Actual_Type (U_Type) then
+ U_Type := Underlying_Type (Base_Type (U_Type));
+ end if;
+
+ -- For a standard subtype, go to the base type
+
if Sloc (U_Type) <= Standard_Location then
U_Type := Base_Type (U_Type);
end if;
else
declare
Decl : Entity_Id;
- Typ : Entity_Id := U_Type;
begin
- -- For the subtype representing a generic actual type, go
- -- to the base type.
-
- if Is_Generic_Actual_Type (Typ) then
- Typ := Base_Type (Typ);
- end if;
-
- Build_From_Any_Function (Loc, Typ, Decl, Fnam);
+ Build_From_Any_Function (Loc, U_Type, Decl, Fnam);
Append_To (Decls, Decl);
end;
end if;
Decls : constant List_Id := New_List;
Stms : constant List_Id := New_List;
- Any_Parameter : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- New_Internal_Name ('A'));
+ Any_Parameter : constant Entity_Id := Make_Temporary (Loc, 'A');
Use_Opaque_Representation : Boolean;
begin
- if Is_Itype (Typ) then
+ -- For a derived type, we can't go past the base type (to the
+ -- parent type) here, because that would cause the attribute's
+ -- formal parameter to have the wrong type; hence the Base_Type
+ -- check here.
+
+ if Is_Itype (Typ) and then Typ /= Base_Type (Typ) then
Build_From_Any_Function
(Loc => Loc,
Typ => Etype (Typ),
-- The returned object
- Res : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- New_Internal_Name ('R'));
+ Res : constant Entity_Id := Make_Temporary (Loc, 'R');
Res_Definition : Node_Id := New_Occurrence_Of (Typ, Loc);
Rec : Entity_Id;
Field : Node_Id)
is
+ Ctyp : Entity_Id;
begin
if Nkind (Field) = N_Defining_Identifier then
-
-- A regular component
+ Ctyp := Etype (Field);
+
Append_To (Stmts,
Make_Assignment_Statement (Loc,
Name => Make_Selected_Component (Loc,
New_Occurrence_Of (Rec, Loc),
Selector_Name =>
New_Occurrence_Of (Field, Loc)),
+
Expression =>
- Build_From_Any_Call (Etype (Field),
+ Build_From_Any_Call (Ctyp,
Build_Get_Aggregate_Element (Loc,
Any => Any,
- TC => Build_TypeCode_Call (Loc,
- Etype (Field), Decls),
- Idx => Make_Integer_Literal (Loc,
- Counter)),
+ TC =>
+ Build_TypeCode_Call (Loc, Ctyp, Decls),
+ Idx =>
+ Make_Integer_Literal (Loc, Counter)),
Decls)));
else
Choice_List : List_Id;
Struct_Any : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- New_Internal_Name ('S'));
+ Make_Temporary (Loc, 'S');
begin
Append_To (Decls,
-- Struct_Counter should be reset before
-- handling a variant part. Indeed only one
-- of the case statement alternatives will be
- -- executed at run-time, so the counter must
+ -- executed at run time, so the counter must
-- start at 0 for every case statement.
Struct_Counter := 0;
new Append_Array_Traversal (
Subprogram => Fnam,
Arry => Res,
- Indices => New_List,
+ Indexes => New_List,
Add_Process_Element => FA_Ary_Add_Process_Element);
Res_Subtype_Indication : Node_Id :=
Left_Opnd =>
Make_Op_Add (Loc,
Left_Opnd =>
- OK_Convert_To (
- Standard_Long_Integer,
- Make_Identifier (Loc, Lnam)),
+ OK_Convert_To
+ (Standard_Long_Integer,
+ Make_Identifier (Loc, Lnam)),
Right_Opnd =>
- OK_Convert_To (
- Standard_Long_Integer,
- Make_Function_Call (Loc,
- Name =>
- New_Occurrence_Of (RTE (
- RE_Get_Nested_Sequence_Length
- ), Loc),
- Parameter_Associations =>
- New_List (
- New_Occurrence_Of (
- Any_Parameter, Loc),
- Make_Integer_Literal (Loc,
- Intval => J))))),
+ OK_Convert_To
+ (Standard_Long_Integer,
+ Make_Function_Call (Loc,
+ Name =>
+ New_Occurrence_Of (RTE (
+ RE_Get_Nested_Sequence_Length
+ ), Loc),
+ Parameter_Associations =>
+ New_List (
+ New_Occurrence_Of (
+ Any_Parameter, Loc),
+ Make_Integer_Literal (Loc,
+ Intval => J))))),
Right_Opnd =>
Make_Integer_Literal (Loc, 1))))));
end if;
if Use_Opaque_Representation then
-
- -- Default: type is represented as an opaque sequence of bytes
-
- declare
- Strm : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- Chars => New_Internal_Name ('S'));
- Res : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- Chars => New_Internal_Name ('R'));
-
- begin
- -- Strm : Buffer_Stream_Type;
-
- Append_To (Decls,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Strm,
- Aliased_Present => True,
- Object_Definition =>
- New_Occurrence_Of (RTE (RE_Buffer_Stream_Type), Loc)));
-
- -- Allocate_Buffer (Strm);
-
- Append_To (Stms,
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of (RTE (RE_Allocate_Buffer), Loc),
- Parameter_Associations => New_List (
- New_Occurrence_Of (Strm, Loc))));
-
- -- Any_To_BS (Strm, A);
-
- Append_To (Stms,
- Make_Procedure_Call_Statement (Loc,
- Name => New_Occurrence_Of (RTE (RE_Any_To_BS), Loc),
- Parameter_Associations => New_List (
- New_Occurrence_Of (Any_Parameter, Loc),
- New_Occurrence_Of (Strm, Loc))));
-
- if Transmit_As_Unconstrained (Typ) then
-
- -- declare
- -- Res : constant T := T'Input (Strm);
- -- begin
- -- Release_Buffer (Strm);
- -- return Res;
- -- end;
-
- Append_To (Stms, Make_Block_Statement (Loc,
- Declarations => New_List (
- Make_Object_Declaration (Loc,
- Defining_Identifier => Res,
- Constant_Present => True,
- Object_Definition => New_Occurrence_Of (Typ, Loc),
- Expression =>
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Typ, Loc),
- Attribute_Name => Name_Input,
- Expressions => New_List (
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (Strm, Loc),
- Attribute_Name => Name_Access))))),
-
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of
- (RTE (RE_Release_Buffer), Loc),
- Parameter_Associations =>
- New_List (New_Occurrence_Of (Strm, Loc))),
-
- Make_Simple_Return_Statement (Loc,
- Expression => New_Occurrence_Of (Res, Loc))))));
-
- else
- -- declare
- -- Res : T;
- -- begin
- -- T'Read (Strm, Res);
- -- Release_Buffer (Strm);
- -- return Res;
- -- end;
-
- Append_To (Stms, Make_Block_Statement (Loc,
- Declarations => New_List (
- Make_Object_Declaration (Loc,
- Defining_Identifier => Res,
- Constant_Present => False,
- Object_Definition =>
- New_Occurrence_Of (Typ, Loc))),
-
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Typ, Loc),
- Attribute_Name => Name_Read,
- Expressions => New_List (
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (Strm, Loc),
- Attribute_Name => Name_Access),
- New_Occurrence_Of (Res, Loc))),
-
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of
- (RTE (RE_Release_Buffer), Loc),
- Parameter_Associations =>
- New_List (New_Occurrence_Of (Strm, Loc))),
-
- Make_Simple_Return_Statement (Loc,
- Expression => New_Occurrence_Of (Res, Loc))))));
- end if;
- end;
+ Assign_Opaque_From_Any (Loc,
+ Stms => Stms,
+ Typ => Typ,
+ N => New_Occurrence_Of (Any_Parameter, Loc),
+ Target => Empty);
end if;
Decl :=
is
Loc : constant Source_Ptr := Sloc (N);
- Typ : Entity_Id := Etype (N);
- U_Type : Entity_Id;
- C_Type : Entity_Id;
- Fnam : Entity_Id := Empty;
- Lib_RE : RE_Id := RE_Null;
+ Typ : Entity_Id := Etype (N);
+ U_Type : Entity_Id;
+ C_Type : Entity_Id;
+ Fnam : Entity_Id := Empty;
+ Lib_RE : RE_Id := RE_Null;
begin
-- If N is a selected component, then maybe its Etype has not been
if No (Typ) and then Nkind (N) = N_Selected_Component then
Typ := Etype (Selector_Name (N));
end if;
+
pragma Assert (Present (Typ));
-- Get full view for private type, completion for incomplete type
Fnam := Find_Inherited_TSS (U_Type, TSS_To_Any);
- -- Check first for Boolean and Character. These are enumeration
- -- types, but we treat them specially, since they may require
- -- special handling in the transfer protocol. However, this
- -- special handling only applies if they have standard
- -- representation, otherwise they are treated like any other
- -- enumeration type.
+ -- For the subtype representing a generic actual type, go to the
+ -- actual type.
+
+ if Is_Generic_Actual_Type (U_Type) then
+ U_Type := Underlying_Type (Base_Type (U_Type));
+ end if;
+
+ -- For a standard subtype, go to the base type
if Sloc (U_Type) <= Standard_Location then
U_Type := Base_Type (U_Type);
if Present (Fnam) then
null;
+ -- Check first for Boolean and Character. These are enumeration
+ -- types, but we treat them specially, since they may require
+ -- special handling in the transfer protocol. However, this
+ -- special handling only applies if they have standard
+ -- representation, otherwise they are treated like any other
+ -- enumeration type.
+
elsif U_Type = Standard_Boolean then
Lib_RE := RE_TA_B;
-- that the expected type of its parameter is U_Type.
if Ekind (Fnam) = E_Function
- and then Present (First_Formal (Fnam))
+ and then Present (First_Formal (Fnam))
then
C_Type := Etype (First_Formal (Fnam));
else
Decls : constant List_Id := New_List;
Stms : constant List_Id := New_List;
- Expr_Parameter : constant Entity_Id :=
- Make_Defining_Identifier (Loc, Name_E);
-
- Any : constant Entity_Id :=
- Make_Defining_Identifier (Loc, Name_A);
+ Expr_Parameter : Entity_Id;
+ Any : Entity_Id;
+ Result_TC : Node_Id;
Any_Decl : Node_Id;
- Result_TC : Node_Id := Build_TypeCode_Call (Loc, Typ, Decls);
Use_Opaque_Representation : Boolean;
-- When True, use stream attributes and represent type as an
-- opaque sequence of bytes.
begin
- if Is_Itype (Typ) then
+ -- For a derived type, we can't go past the base type (to the
+ -- parent type) here, because that would cause the attribute's
+ -- formal parameter to have the wrong type; hence the Base_Type
+ -- check here.
+
+ if Is_Itype (Typ) and then Typ /= Base_Type (Typ) then
Build_To_Any_Function
- (Loc => Loc,
+ (Loc => Loc,
Typ => Etype (Typ),
Decl => Decl,
Fnam => Fnam);
return;
end if;
+ Expr_Parameter := Make_Defining_Identifier (Loc, Name_E);
+ Any := Make_Defining_Identifier (Loc, Name_A);
+ Result_TC := Build_TypeCode_Call (Loc, Typ, Decls);
+
Fnam := Make_Helper_Function_Name (Loc, Typ, Name_To_Any);
Spec :=
Choice_List : List_Id;
Union_Any : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- New_Internal_Name ('V'));
+ Make_Temporary (Loc, 'V');
Struct_Any : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- New_Internal_Name ('S'));
+ Make_Temporary (Loc, 'S');
function Make_Discriminant_Reference
return Node_Id;
-- Struct_Counter should be reset before
-- handling a variant part. Indeed only one
-- of the case statement alternatives will be
- -- executed at run-time, so the counter must
+ -- executed at run time, so the counter must
-- start at 0 for every case statement.
Struct_Counter := 0;
- TA_Append_Record_Traversal (
- Stmts => VP_Stmts,
- Clist => Component_List (Variant),
- Container => Struct_Any,
- Counter => Struct_Counter);
+ TA_Append_Record_Traversal
+ (Stmts => VP_Stmts,
+ Clist => Component_List (Variant),
+ Container => Struct_Any,
+ Counter => Struct_Counter);
-- Append inner struct to union aggregate
Append_To (VP_Stmts,
Make_Procedure_Call_Statement (Loc,
Name =>
- New_Occurrence_Of (
- RTE (RE_Add_Aggregate_Element), Loc),
+ New_Occurrence_Of
+ (RTE (RE_Add_Aggregate_Element), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Union_Any, Loc),
New_Occurrence_Of (Struct_Any, Loc))));
Append_To (VP_Stmts,
Make_Procedure_Call_Statement (Loc,
Name =>
- New_Occurrence_Of (
- RTE (RE_Add_Aggregate_Element), Loc),
+ New_Occurrence_Of
+ (RTE (RE_Add_Aggregate_Element), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Container, Loc),
New_Occurrence_Of
declare
Dummy_Any : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- Chars => New_Internal_Name ('A'));
+ Make_Temporary (Loc, 'A');
begin
Append_To (Decls,
Set_Expression (Any_Decl,
Make_Function_Call (Loc,
- Name => New_Occurrence_Of (
- RTE (RE_Any_Aggregate_Build), Loc),
+ Name => New_Occurrence_Of
+ (RTE (RE_Any_Aggregate_Build), Loc),
Parameter_Associations => New_List (
Result_TC,
Make_Aggregate (Loc,
new Append_Array_Traversal (
Subprogram => Fnam,
Arry => Expr_Parameter,
- Indices => New_List,
+ Indexes => New_List,
Add_Process_Element => TA_Ary_Add_Process_Element);
Index : Node_Id;
if Use_Opaque_Representation then
declare
- Strm : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- Chars => New_Internal_Name ('S'));
+ Strm : constant Entity_Id := Make_Temporary (Loc, 'S');
-- Stream used to store data representation produced by
-- stream attribute.
New_Occurrence_Of (RTE (RE_Buffer_Stream_Type), Loc)));
-- Generate:
- -- Allocate_Buffer (Strm);
-
- Append_To (Stms,
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of (RTE (RE_Allocate_Buffer), Loc),
- Parameter_Associations => New_List (
- New_Occurrence_Of (Strm, Loc))));
-
- -- Generate:
-- T'Output (Strm'Access, E);
Append_To (Stms,
Fnam := Find_Inherited_TSS (U_Type, TSS_TypeCode);
end if;
- if No (Fnam) then
- if Sloc (U_Type) <= Standard_Location then
+ -- For the subtype representing a generic actual type, go to the
+ -- actual type.
- -- Do not try to build alias typecodes for subtypes from
- -- Standard.
+ if Is_Generic_Actual_Type (U_Type) then
+ U_Type := Underlying_Type (Base_Type (U_Type));
+ end if;
- U_Type := Base_Type (U_Type);
- end if;
+ -- For a standard subtype, go to the base type
+ if Sloc (U_Type) <= Standard_Location then
+ U_Type := Base_Type (U_Type);
+ end if;
+
+ if No (Fnam) then
if U_Type = Standard_Boolean then
Lib_RE := RE_TC_B;
Type_Name_Str : String_Id;
Type_Repo_Id_Str : String_Id;
+ -- Start of processing for Build_TypeCode_Function
+
begin
- if Is_Itype (Typ) then
+ -- For a derived type, we can't go past the base type (to the
+ -- parent type) here, because that would cause the attribute's
+ -- formal parameter to have the wrong type; hence the Base_Type
+ -- check here.
+
+ if Is_Itype (Typ) and then Typ /= Base_Type (Typ) then
Build_TypeCode_Function
(Loc => Loc,
- Typ => Etype (Typ),
- Decl => Decl,
- Fnam => Fnam);
+ Typ => Etype (Typ),
+ Decl => Decl,
+ Fnam => Fnam);
return;
end if;
Element_Expr : constant Node_Id :=
Make_Indexed_Component (Loc,
New_Occurrence_Of (Arry, Loc),
- Indices);
+ Indexes);
begin
Set_Etype (Element_Expr, Component_Type (Typ));
Add_Process_Element (Stmts,
return;
end if;
- Append_To (Indices,
+ Append_To (Indexes,
Make_Identifier (Loc, New_External_Name ('L', Depth)));
if not Constrained or else Depth > 1 then
Name => New_Occurrence_Of (RTE (RE_Get_TC), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Any, Loc)));
+
else
Inner_Any_TypeCode_Expr :=
Make_Function_Call (Loc,
New_Occurrence_Of (Any, Loc),
Make_Integer_Literal (Loc, Ndim)));
end if;
+
else
Inner_Any_TypeCode_Expr :=
Make_Function_Call (Loc,
begin
declare
Serial : Nat := 0;
- -- For tagged types, we use a canonical name so that it matches
- -- the primitive spec. For all other cases, we use a serialized
- -- name so that multiple generations of the same procedure do
- -- not clash.
+ -- For tagged types that aren't frozen yet, generate the helper
+ -- under its canonical name so that it matches the primitive
+ -- spec. For all other cases, we use a serialized name so that
+ -- multiple generations of the same procedure do not clash.
begin
- if not Is_Tagged_Type (Typ) then
+ if Is_Tagged_Type (Typ) and then not Is_Frozen (Typ) then
+ null;
+ else
Serial := Increment_Serial_Number;
end if;
- -- Use prefixed underscore to avoid potential clash with used
+ -- Use prefixed underscore to avoid potential clash with user
-- identifier (we use attribute names for Nam).
return
Make_Defining_Identifier (Loc,
Chars =>
New_External_Name
- (Related_Id => Nam,
- Suffix => ' ', Suffix_Index => Serial,
- Prefix => '_'));
+ (Related_Id => Nam,
+ Suffix => ' ',
+ Suffix_Index => Serial,
+ Prefix => '_'));
end;
end Make_Helper_Function_Name;
end Helpers;
Pkg_Name := String_From_Name_Buffer;
Inst :=
Make_Package_Instantiation (Loc,
- Defining_Unit_Name =>
- Make_Defining_Identifier (Loc, New_Internal_Name ('R')),
+ Defining_Unit_Name => Make_Temporary (Loc, 'R'),
+
Name =>
New_Occurrence_Of (RTE (RE_RCI_Locator), Loc),
+
Generic_Associations => New_List (
Make_Generic_Association (Loc,
Selector_Name =>
Explicit_Generic_Actual_Parameter =>
Make_String_Literal (Loc,
Strval => Pkg_Name)),
+
Make_Generic_Association (Loc,
Selector_Name =>
Make_Identifier (Loc, Name_Version),
Attribute_Name =>
Name_Version))));
- RCI_Locator_Table.Set (Defining_Unit_Name (Package_Spec),
- Defining_Unit_Name (Inst));
+ RCI_Locator_Table.Set
+ (Defining_Unit_Name (Package_Spec),
+ Defining_Unit_Name (Inst));
return Inst;
end RCI_Package_Locator;
begin
case Get_PCS_Name is
when Name_PolyORB_DSA =>
- PolyORB_Support.Add_Obj_RPC_Receiver_Completion (Loc,
- Decls, RPC_Receiver, Stub_Elements);
+ PolyORB_Support.Add_Obj_RPC_Receiver_Completion
+ (Loc, Decls, RPC_Receiver, Stub_Elements);
when others =>
- GARLIC_Support.Add_Obj_RPC_Receiver_Completion (Loc,
- Decls, RPC_Receiver, Stub_Elements);
+ GARLIC_Support.Add_Obj_RPC_Receiver_Completion
+ (Loc, Decls, RPC_Receiver, Stub_Elements);
end case;
end Specific_Add_Obj_RPC_Receiver_Completion;
begin
case Get_PCS_Name is
when Name_PolyORB_DSA =>
- return PolyORB_Support.Build_Stub_Target (Loc,
- Decls, RCI_Locator, Controlling_Parameter);
+ return
+ PolyORB_Support.Build_Stub_Target
+ (Loc, Decls, RCI_Locator, Controlling_Parameter);
when others =>
- return GARLIC_Support.Build_Stub_Target (Loc,
- Decls, RCI_Locator, Controlling_Parameter);
+ return
+ GARLIC_Support.Build_Stub_Target
+ (Loc, Decls, RCI_Locator, Controlling_Parameter);
end case;
end Specific_Build_Stub_Target;
procedure Specific_Build_Stub_Type
(RACW_Type : Entity_Id;
- Stub_Type : Entity_Id;
- Stub_Type_Decl : out Node_Id;
+ Stub_Type_Comps : out List_Id;
RPC_Receiver_Decl : out Node_Id)
is
begin
case Get_PCS_Name is
when Name_PolyORB_DSA =>
- PolyORB_Support.Build_Stub_Type (
- RACW_Type, Stub_Type,
- Stub_Type_Decl, RPC_Receiver_Decl);
+ PolyORB_Support.Build_Stub_Type
+ (RACW_Type, Stub_Type_Comps, RPC_Receiver_Decl);
when others =>
- GARLIC_Support.Build_Stub_Type (
- RACW_Type, Stub_Type,
- Stub_Type_Decl, RPC_Receiver_Decl);
+ GARLIC_Support.Build_Stub_Type
+ (RACW_Type, Stub_Type_Comps, RPC_Receiver_Decl);
end case;
end Specific_Build_Stub_Type;
+ -----------------------------------------------
+ -- Specific_Build_Subprogram_Receiving_Stubs --
+ -----------------------------------------------
+
function Specific_Build_Subprogram_Receiving_Stubs
(Vis_Decl : Node_Id;
Asynchronous : Boolean;
begin
case Get_PCS_Name is
when Name_PolyORB_DSA =>
- return PolyORB_Support.Build_Subprogram_Receiving_Stubs
- (Vis_Decl,
- Asynchronous,
- Dynamically_Asynchronous,
- Stub_Type,
- RACW_Type,
- Parent_Primitive);
+ return
+ PolyORB_Support.Build_Subprogram_Receiving_Stubs
+ (Vis_Decl,
+ Asynchronous,
+ Dynamically_Asynchronous,
+ Stub_Type,
+ RACW_Type,
+ Parent_Primitive);
when others =>
- return GARLIC_Support.Build_Subprogram_Receiving_Stubs
- (Vis_Decl,
- Asynchronous,
- Dynamically_Asynchronous,
- Stub_Type,
- RACW_Type,
- Parent_Primitive);
+ return
+ GARLIC_Support.Build_Subprogram_Receiving_Stubs
+ (Vis_Decl,
+ Asynchronous,
+ Dynamically_Asynchronous,
+ Stub_Type,
+ RACW_Type,
+ Parent_Primitive);
end case;
end Specific_Build_Subprogram_Receiving_Stubs;