diff options
Diffstat (limited to 'gcc/ada/exp_dist.adb')
| -rw-r--r-- | gcc/ada/exp_dist.adb | 3760 |
1 files changed, 3760 insertions, 0 deletions
diff --git a/gcc/ada/exp_dist.adb b/gcc/ada/exp_dist.adb new file mode 100644 index 00000000000..c0d79d12d22 --- /dev/null +++ b/gcc/ada/exp_dist.adb @@ -0,0 +1,3760 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P_ D I S T -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.125 $ +-- -- +-- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Einfo; use Einfo; +with Elists; use Elists; +with Exp_Tss; use Exp_Tss; +with Exp_Util; use Exp_Util; +with GNAT.HTable; use GNAT.HTable; +with Lib; use Lib; +with Namet; use Namet; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Opt; use Opt; +with Rtsfind; use Rtsfind; +with Sem; use Sem; +with Sem_Ch3; use Sem_Ch3; +with Sem_Ch8; use Sem_Ch8; +with Sem_Dist; use Sem_Dist; +with Sem_Util; use Sem_Util; +with Sinfo; use Sinfo; +with Snames; use Snames; +with Stand; use Stand; +with Stringt; use Stringt; +with Tbuild; use Tbuild; +with Uintp; use Uintp; +with Uname; use Uname; + +package body Exp_Dist is + + -- The following model has been used to implement distributed objects: + -- given a designated type D and a RACW type R, then a record of the + -- form: + -- type Stub is tagged record + -- [...declaration similar to s-parint.ads RACW_Stub_Type...] + -- end Stub; + -- is built. This type has two properties: + -- + -- 1) Since it has the same structure than RACW_Stub_Type, it can be + -- converted to and from this type to make it suitable for + -- System.Partition_Interface.Get_Unique_Remote_Pointer in order + -- to avoid memory leaks when the same remote object arrive on the + -- same partition by following different pathes + -- + -- 2) It also has the same dispatching table as the designated type D, + -- and thus can be used as an object designated by a value of type + -- R on any partition other than the one on which the object has + -- been created, since only dispatching calls will be performed and + -- the fields themselves will not be used. We call Derive_Subprograms + -- to fake half a derivation to ensure that the subprograms do have + -- the same dispatching table. + + ----------------------- + -- Local subprograms -- + ----------------------- + + procedure Build_General_Calling_Stubs + (Decls : in List_Id; + Statements : in List_Id; + Target_Partition : in Entity_Id; + RPC_Receiver : in Node_Id; + Subprogram_Id : in Node_Id; + Asynchronous : in Node_Id := Empty; + Is_Known_Asynchronous : in Boolean := False; + Is_Known_Non_Asynchronous : in Boolean := False; + Is_Function : in Boolean; + Spec : in Node_Id; + Object_Type : in Entity_Id := Empty; + Nod : in Node_Id); + -- Build calling stubs for general purpose. The parameters are: + -- Decls : a place to put declarations + -- Statements : a place to put statements + -- Target_Partition : a node containing the target partition that must + -- be a N_Defining_Identifier + -- RPC_Receiver : a node containing the RPC receiver + -- Subprogram_Id : a node containing the subprogram ID + -- Asynchronous : True if an APC must be made instead of an RPC. + -- The value needs not be supplied if one of the + -- Is_Known_... is True. + -- Is_Known_Async... : True if we know that this is asynchronous + -- Is_Known_Non_A... : True if we know that this is not asynchronous + -- Spec : a node with a Parameter_Specifications and + -- a Subtype_Mark if applicable + -- Object_Type : in case of a RACW, parameters of type access to + -- Object_Type will be marshalled using the + -- address of this object (the addr field) rather + -- than using the 'Write on the object itself + -- Nod : used to provide sloc for generated code + + function Build_Subprogram_Calling_Stubs + (Vis_Decl : Node_Id; + Subp_Id : Int; + Asynchronous : Boolean; + Dynamically_Asynchronous : Boolean := False; + Stub_Type : Entity_Id := Empty; + Locator : Entity_Id := Empty; + New_Name : Name_Id := No_Name) + return Node_Id; + -- Build the calling stub for a given subprogram with the subprogram ID + -- being Subp_Id. If Stub_Type is given, then the "addr" field of + -- parameters of this type will be marshalled instead of the object + -- itself. It will then be converted into Stub_Type before performing + -- the real call. If Dynamically_Asynchronous is True, then it will be + -- computed at run time whether the call is asynchronous or not. + -- Otherwise, the value of the formal Asynchronous will be used. + -- If Locator is not Empty, it will be used instead of RCI_Cache. If + -- New_Name is given, then it will be used instead of the original name. + + function Build_Subprogram_Receiving_Stubs + (Vis_Decl : Node_Id; + Asynchronous : Boolean; + Dynamically_Asynchronous : Boolean := False; + Stub_Type : Entity_Id := Empty; + RACW_Type : Entity_Id := Empty; + Parent_Primitive : Entity_Id := Empty) + return Node_Id; + -- Build the receiving stub for a given subprogram. The subprogram + -- declaration is also built by this procedure, and the value returned + -- is a N_Subprogram_Body. If a parameter of type access to Stub_Type is + -- found in the specification, then its address is read from the stream + -- instead of the object itself and converted into an access to + -- class-wide type before doing the real call using any of the RACW type + -- pointing on the designated type. + + function Build_Ordered_Parameters_List (Spec : Node_Id) return List_Id; + -- Return an ordered parameter list: unconstrained parameters are put + -- at the beginning of the list and constrained ones are put after. If + -- there are no parameters, an empty list is returned. + + procedure Add_Calling_Stubs_To_Declarations + (Pkg_Spec : in Node_Id; + Decls : in List_Id); + -- Add calling stubs to the declarative part + + procedure Add_Receiving_Stubs_To_Declarations + (Pkg_Spec : in Node_Id; + Decls : in List_Id); + -- Add receiving stubs to the declarative part + + procedure Add_RAS_Dereference_Attribute (N : in Node_Id); + -- Add a subprogram body for RAS dereference + + procedure Add_RAS_Access_Attribute (N : in Node_Id); + -- Add a subprogram body for RAS Access attribute + + function Could_Be_Asynchronous (Spec : Node_Id) return Boolean; + -- Return True if nothing prevents the program whose specification is + -- given to be asynchronous (i.e. no out parameter). + + function Get_Pkg_Name_String_Id (Decl_Node : Node_Id) return String_Id; + function Get_String_Id (Val : String) return String_Id; + -- Ugly functions used to retrieve a package name. Inherited from the + -- old exp_dist.adb and not rewritten yet ??? + + function Pack_Entity_Into_Stream_Access + (Loc : Source_Ptr; + Stream : Entity_Id; + Object : Entity_Id; + Etyp : Entity_Id := Empty) + return Node_Id; + -- Pack Object (of type Etyp) into Stream. If Etyp is not given, + -- then Etype (Object) will be used if present. If the type is + -- constrained, then 'Write will be used to output the object, + -- If the type is unconstrained, 'Output will be used. + + function Pack_Node_Into_Stream + (Loc : Source_Ptr; + Stream : Entity_Id; + Object : Node_Id; + Etyp : Entity_Id) + return Node_Id; + -- Similar to above, with an arbitrary node instead of an entity + + function Pack_Node_Into_Stream_Access + (Loc : Source_Ptr; + Stream : Entity_Id; + Object : Node_Id; + Etyp : Entity_Id) + return Node_Id; + -- Similar to above, with Stream instead of Stream'Access + + function Copy_Specification + (Loc : Source_Ptr; + Spec : Node_Id; + Object_Type : Entity_Id := Empty; + Stub_Type : Entity_Id := Empty; + New_Name : Name_Id := No_Name) + return Node_Id; + -- Build a specification from another one. If Object_Type is not Empty + -- and any access to Object_Type is found, then it is replaced by an + -- access to Stub_Type. If New_Name is given, then it will be used as + -- the name for the newly created spec. + + function Scope_Of_Spec (Spec : Node_Id) return Entity_Id; + -- Return the scope represented by a given spec + + function Need_Extra_Constrained (Parameter : Node_Id) return Boolean; + -- Return True if the current parameter needs an extra formal to reflect + -- its constrained status. + + function Is_RACW_Controlling_Formal + (Parameter : Node_Id; Stub_Type : Entity_Id) + return Boolean; + -- Return True if the current parameter is a controlling formal argument + -- of type Stub_Type or access to Stub_Type. + + type Stub_Structure is record + Stub_Type : Entity_Id; + Stub_Type_Access : Entity_Id; + Object_RPC_Receiver : Entity_Id; + RPC_Receiver_Stream : Entity_Id; + RPC_Receiver_Result : Entity_Id; + RACW_Type : Entity_Id; + end record; + -- This structure is necessary because of the two phases analysis of + -- a RACW declaration occurring in the same Remote_Types package as the + -- designated type. RACW_Type is any of the RACW types pointing on this + -- designated type, it is used here to save an anonymous type creation + -- for each primitive operation. + + Empty_Stub_Structure : constant Stub_Structure := + (Empty, Empty, Empty, Empty, Empty, Empty); + + type Hash_Index is range 0 .. 50; + function Hash (F : Entity_Id) return Hash_Index; + + package Stubs_Table is + new Simple_HTable (Header_Num => Hash_Index, + Element => Stub_Structure, + No_Element => Empty_Stub_Structure, + Key => Entity_Id, + Hash => Hash, + Equal => "="); + -- Mapping between a RACW designated type and its stub type + + package Asynchronous_Flags_Table is + new Simple_HTable (Header_Num => Hash_Index, + Element => Node_Id, + No_Element => Empty, + Key => Entity_Id, + Hash => Hash, + Equal => "="); + -- Mapping between a RACW type and the node holding the value True if + -- the RACW is asynchronous and False otherwise. + + package RCI_Locator_Table is + new Simple_HTable (Header_Num => Hash_Index, + Element => Entity_Id, + No_Element => Empty, + Key => Entity_Id, + Hash => Hash, + Equal => "="); + -- Mapping between a RCI package on which All_Calls_Remote applies and + -- the generic instantiation of RCI_Info for this package. + + package RCI_Calling_Stubs_Table is + new Simple_HTable (Header_Num => Hash_Index, + Element => Entity_Id, + No_Element => Empty, + Key => Entity_Id, + Hash => Hash, + Equal => "="); + -- Mapping between a RCI subprogram and the corresponding calling stubs + + procedure Add_Stub_Type + (Designated_Type : in Entity_Id; + RACW_Type : in Entity_Id; + Decls : in List_Id; + Stub_Type : out Entity_Id; + Stub_Type_Access : out Entity_Id; + Object_RPC_Receiver : out Entity_Id; + Existing : out Boolean); + -- Add the declaration of the stub type, the access to stub type and the + -- object RPC receiver at the end of Decls. If these already exist, + -- then nothing is added in the tree but the right values are returned + -- anyhow and Existing is set to True. + + procedure Add_RACW_Read_Attribute + (RACW_Type : in Entity_Id; + Stub_Type : in Entity_Id; + Stub_Type_Access : in Entity_Id; + Declarations : in List_Id); + -- Add Read attribute in Decls for the RACW type. The Read attribute + -- is added right after the RACW_Type declaration while the body is + -- inserted after Declarations. + + procedure Add_RACW_Write_Attribute + (RACW_Type : in Entity_Id; + Stub_Type : in Entity_Id; + Stub_Type_Access : in Entity_Id; + Object_RPC_Receiver : in Entity_Id; + Declarations : in List_Id); + -- Same thing for the Write attribute + + procedure Add_RACW_Read_Write_Attributes + (RACW_Type : in Entity_Id; + Stub_Type : in Entity_Id; + Stub_Type_Access : in Entity_Id; + Object_RPC_Receiver : in Entity_Id; + Declarations : in List_Id); + -- Add Read and Write attributes declarations and bodies for a given + -- RACW type. The declarations are added just after the declaration + -- of the RACW type itself, while the bodies are inserted at the end + -- of Decls. + + function RCI_Package_Locator + (Loc : Source_Ptr; + Package_Spec : Node_Id) + return Node_Id; + -- Instantiate the generic package RCI_Info in order to locate the + -- RCI package whose spec is given as argument. + + function Make_Tag_Check (Loc : Source_Ptr; N : Node_Id) return Node_Id; + -- Surround a node N by a tag check, as in: + -- begin + -- <N>; + -- exception + -- when E : Ada.Tags.Tag_Error => + -- Raise_Exception (Program_Error'Identity, + -- Exception_Message (E)); + -- end; + + function Input_With_Tag_Check + (Loc : Source_Ptr; + Var_Type : Entity_Id; + Stream : Entity_Id) + return Node_Id; + -- Return a function with the following form: + -- function R return Var_Type is + -- begin + -- return Var_Type'Input (S); + -- exception + -- when E : Ada.Tags.Tag_Error => + -- Raise_Exception (Program_Error'Identity, + -- Exception_Message (E)); + -- end R; + + ------------------------------------ + -- Local variables and structures -- + ------------------------------------ + + RCI_Cache : Node_Id; + + Output_From_Constrained : constant array (Boolean) of Name_Id := + (False => Name_Output, + True => Name_Write); + -- The attribute to choose depending on the fact that the parameter + -- is constrained or not. There is no such thing as Input_From_Constrained + -- since this require separate mechanisms ('Input is a function while + -- 'Read is a procedure). + + --------------------------------------- + -- Add_Calling_Stubs_To_Declarations -- + --------------------------------------- + + procedure Add_Calling_Stubs_To_Declarations + (Pkg_Spec : in Node_Id; + Decls : in List_Id) + is + Current_Subprogram_Number : Int := 0; + Current_Declaration : Node_Id; + + Loc : constant Source_Ptr := Sloc (Pkg_Spec); + + RCI_Instantiation : Node_Id; + + Subp_Stubs : Node_Id; + + begin + -- The first thing added is an instantiation of the generic package + -- System.Partition_interface.RCI_Info with the name of the (current) + -- remote package. This will act as an interface with the name server + -- to determine the Partition_ID and the RPC_Receiver for the + -- receiver of this package. + + RCI_Instantiation := RCI_Package_Locator (Loc, Pkg_Spec); + RCI_Cache := Defining_Unit_Name (RCI_Instantiation); + + Append_To (Decls, RCI_Instantiation); + Analyze (RCI_Instantiation); + + -- For each subprogram declaration visible in the spec, we do + -- build a body. We also increment a counter to assign a different + -- Subprogram_Id to each subprograms. The receiving stubs processing + -- do use the same mechanism and will thus assign the same Id and + -- do the correct dispatching. + + Current_Declaration := First (Visible_Declarations (Pkg_Spec)); + + while Current_Declaration /= Empty loop + + if Nkind (Current_Declaration) = N_Subprogram_Declaration + and then Comes_From_Source (Current_Declaration) + then + pragma Assert (Current_Subprogram_Number = + Get_Subprogram_Id (Defining_Unit_Name (Specification ( + Current_Declaration)))); + + Subp_Stubs := + Build_Subprogram_Calling_Stubs ( + Vis_Decl => Current_Declaration, + Subp_Id => Current_Subprogram_Number, + Asynchronous => + Nkind (Specification (Current_Declaration)) = + N_Procedure_Specification + and then + Is_Asynchronous (Defining_Unit_Name (Specification + (Current_Declaration)))); + + Append_To (Decls, Subp_Stubs); + Analyze (Subp_Stubs); + + Current_Subprogram_Number := Current_Subprogram_Number + 1; + end if; + + Next (Current_Declaration); + end loop; + + end Add_Calling_Stubs_To_Declarations; + + ----------------------- + -- Add_RACW_Features -- + ----------------------- + + procedure Add_RACW_Features (RACW_Type : in Entity_Id) + is + Desig : constant Entity_Id := + Etype (Designated_Type (RACW_Type)); + Decls : List_Id := + List_Containing (Declaration_Node (RACW_Type)); + + Same_Scope : constant Boolean := + Scope (Desig) = Scope (RACW_Type); + + Stub_Type : Entity_Id; + Stub_Type_Access : Entity_Id; + Object_RPC_Receiver : Entity_Id; + Existing : Boolean; + + begin + if not Expander_Active then + return; + end if; + + if Same_Scope then + + -- We are declaring a RACW in the same package than its designated + -- type, so the list to use for late declarations must be the + -- private part of the package. We do know that this private part + -- exists since the designated type has to be a private one. + + Decls := Private_Declarations + (Package_Specification_Of_Scope (Current_Scope)); + + elsif Nkind (Parent (Decls)) = N_Package_Specification + and then Present (Private_Declarations (Parent (Decls))) + then + Decls := Private_Declarations (Parent (Decls)); + end if; + + -- If we were unable to find the declarations, that means that the + -- completion of the type was missing. We can safely return and let + -- the error be caught by the semantic analysis. + + if No (Decls) then + return; + end if; + + Add_Stub_Type + (Designated_Type => Desig, + RACW_Type => RACW_Type, + Decls => Decls, + Stub_Type => Stub_Type, + Stub_Type_Access => Stub_Type_Access, + Object_RPC_Receiver => Object_RPC_Receiver, + Existing => Existing); + + Add_RACW_Read_Write_Attributes + (RACW_Type => RACW_Type, + Stub_Type => Stub_Type, + Stub_Type_Access => Stub_Type_Access, + Object_RPC_Receiver => Object_RPC_Receiver, + Declarations => Decls); + + if not Same_Scope and then not Existing then + + -- The RACW has been declared in another scope than the designated + -- type and has not been handled by another RACW in the same + -- package as the first one, so add primitive for the stub type + -- here. + + Add_RACW_Primitive_Declarations_And_Bodies + (Designated_Type => Desig, + Insertion_Node => + Parent (Declaration_Node (Object_RPC_Receiver)), + Decls => Decls); + + else + Add_Access_Type_To_Process (E => Desig, A => RACW_Type); + end if; + end Add_RACW_Features; + + ------------------------------------------------- + -- Add_RACW_Primitive_Declarations_And_Bodies -- + ------------------------------------------------- + + procedure Add_RACW_Primitive_Declarations_And_Bodies + (Designated_Type : in Entity_Id; + Insertion_Node : in Node_Id; + Decls : in List_Id) + is + -- Set sloc of generated declaration to be that of the + -- insertion node, so the declarations are recognized as + -- belonging to the current package. + + Loc : constant Source_Ptr := Sloc (Insertion_Node); + + Stub_Elements : constant Stub_Structure := + Stubs_Table.Get (Designated_Type); + + pragma Assert (Stub_Elements /= Empty_Stub_Structure); + + Current_Insertion_Node : Node_Id := Insertion_Node; + + RPC_Receiver_Declarations : List_Id; + RPC_Receiver_Statements : List_Id; + RPC_Receiver_Case_Alternatives : constant List_Id := New_List; + RPC_Receiver_Subp_Id : Entity_Id; + + Current_Primitive_Elmt : Elmt_Id; + Current_Primitive : Entity_Id; + Current_Primitive_Body : Node_Id; + Current_Primitive_Spec : Node_Id; + Current_Primitive_Decl : Node_Id; + Current_Primitive_Number : Int := 0; + + Current_Primitive_Alias : Node_Id; + + Current_Receiver : Entity_Id; + Current_Receiver_Body : Node_Id; + + RPC_Receiver_Decl : Node_Id; + + Possibly_Asynchronous : Boolean; + + begin + + if not Expander_Active then + return; + end if; + + -- Build callers, receivers for every primitive operations and a RPC + -- receiver for this type. + + if Present (Primitive_Operations (Designated_Type)) then + + Current_Primitive_Elmt := + First_Elmt (Primitive_Operations (Designated_Type)); + + while Current_Primitive_Elmt /= No_Elmt loop + + Current_Primitive := Node (Current_Primitive_Elmt); + + -- Copy the primitive of all the parents, except predefined + -- ones that are not remotely dispatching. + + if Chars (Current_Primitive) /= Name_uSize + and then Chars (Current_Primitive) /= Name_uDeep_Finalize + then + -- The first thing to do is build an up-to-date copy of + -- the spec with all the formals referencing Designated_Type + -- transformed into formals referencing Stub_Type. Since this + -- primitive may have been inherited, go back the alias chain + -- until the real primitive has been found. + + Current_Primitive_Alias := Current_Primitive; + while Present (Alias (Current_Primitive_Alias)) loop + pragma Assert + (Current_Primitive_Alias + /= Alias (Current_Primitive_Alias)); + Current_Primitive_Alias := Alias (Current_Primitive_Alias); + end loop; + + Current_Primitive_Spec := + Copy_Specification (Loc, + Spec => Parent (Current_Primitive_Alias), + Object_Type => Designated_Type, + Stub_Type => Stub_Elements.Stub_Type); + + Current_Primitive_Decl := + Make_Subprogram_Declaration (Loc, + Specification => Current_Primitive_Spec); + + Insert_After (Current_Insertion_Node, Current_Primitive_Decl); + Analyze (Current_Primitive_Decl); + Current_Insertion_Node := Current_Primitive_Decl; + + Possibly_Asynchronous := + Nkind (Current_Primitive_Spec) = N_Procedure_Specification + and then Could_Be_Asynchronous (Current_Primitive_Spec); + + Current_Primitive_Body := + Build_Subprogram_Calling_Stubs + (Vis_Decl => Current_Primitive_Decl, + Subp_Id => Current_Primitive_Number, + Asynchronous => Possibly_Asynchronous, + Dynamically_Asynchronous => Possibly_Asynchronous, + Stub_Type => Stub_Elements.Stub_Type); + Append_To (Decls, Current_Primitive_Body); + + -- Analyzing the body here would cause the Stub type to be + -- frozen, thus preventing subsequent primitive declarations. + -- For this reason, it will be analyzed later in the + -- regular flow. + + -- Build the receiver stubs + + Current_Receiver_Body := + Build_Subprogram_Receiving_Stubs + (Vis_Decl => Current_Primitive_Decl, + Asynchronous => Possibly_Asynchronous, + Dynamically_Asynchronous => Possibly_Asynchronous, + Stub_Type => Stub_Elements.Stub_Type, + RACW_Type => Stub_Elements.RACW_Type, + Parent_Primitive => Current_Primitive); + + Current_Receiver := + Defining_Unit_Name (Specification (Current_Receiver_Body)); + + Append_To (Decls, Current_Receiver_Body); + + -- Add a case alternative to the receiver + + Append_To (RPC_Receiver_Case_Alternatives, + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => New_List ( + Make_Integer_Literal (Loc, Current_Primitive_Number)), + + Statements => New_List ( + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (Current_Receiver, Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of + (Stub_Elements.RPC_Receiver_Stream, Loc), + New_Occurrence_Of + (Stub_Elements.RPC_Receiver_Result, Loc)))))); + + -- Increment the index of current primitive + + Current_Primitive_Number := Current_Primitive_Number + 1; + end if; + + Next_Elmt (Current_Primitive_Elmt); + end loop; + end if; + + -- Build the case statement and the heart of the subprogram + + Append_To (RPC_Receiver_Case_Alternatives, + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => New_List (Make_Others_Choice (Loc)), + Statements => New_List (Make_Null_Statement (Loc)))); + + RPC_Receiver_Subp_Id := + Make_Defining_Identifier (Loc, New_Internal_Name ('S')); + + RPC_Receiver_Declarations := New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => RPC_Receiver_Subp_Id, + Object_Definition => + New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc))); + + RPC_Receiver_Statements := New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc), + Attribute_Name => + Name_Read, + Expressions => New_List ( + New_Occurrence_Of (Stub_Elements.RPC_Receiver_Stream, Loc), + New_Occurrence_Of (RPC_Receiver_Subp_Id, Loc)))); + + Append_To (RPC_Receiver_Statements, + Make_Case_Statement (Loc, + Expression => + New_Occurrence_Of (RPC_Receiver_Subp_Id, Loc), + Alternatives => RPC_Receiver_Case_Alternatives)); + + RPC_Receiver_Decl := + Make_Subprogram_Body (Loc, + Specification => + Copy_Specification (Loc, + Parent (Stub_Elements.Object_RPC_Receiver)), + Declarations => RPC_Receiver_Declarations, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => RPC_Receiver_Statements)); + + Append_To (Decls, RPC_Receiver_Decl); + + -- Do not analyze RPC receiver at this stage since it will otherwise + -- reference subprograms that have not been analyzed yet. It will + -- be analyzed in the regular flow. + + end Add_RACW_Primitive_Declarations_And_Bodies; + + ----------------------------- + -- Add_RACW_Read_Attribute -- + ----------------------------- + + procedure Add_RACW_Read_Attribute + (RACW_Type : in Entity_Id; + Stub_Type : in Entity_Id; + Stub_Type_Access : in Entity_Id; + Declarations : in List_Id) + is + Loc : constant Source_Ptr := Sloc (RACW_Type); + + Proc_Spec : Node_Id; + -- Specification and body of the currently built procedure + + Proc_Body_Spec : Node_Id; + + Proc_Decl : Node_Id; + Attr_Decl : Node_Id; + + Body_Node : Node_Id; + + Decls : List_Id; + Statements : List_Id; + Local_Statements : List_Id; + Remote_Statements : List_Id; + -- Various parts of the procedure + + Procedure_Name : constant Name_Id := + New_Internal_Name ('R'); + Source_Partition : constant Entity_Id := + Make_Defining_Identifier + (Loc, New_Internal_Name ('P')); + Source_Receiver : constant Entity_Id := + Make_Defining_Identifier + (Loc, New_Internal_Name ('S')); + Source_Address : constant Entity_Id := + Make_Defining_Identifier + (Loc, New_Internal_Name ('P')); + Stream_Parameter : constant Entity_Id := + Make_Defining_Identifier + (Loc, New_Internal_Name ('S')); + Result : constant Entity_Id := + Make_Defining_Identifier + (Loc, New_Internal_Name ('P')); + Stubbed_Result : constant Entity_Id := + Make_Defining_Identifier + (Loc, New_Internal_Name ('S')); + Asynchronous_Flag : constant Entity_Id := + Make_Defining_Identifier + (Loc, New_Internal_Name ('S')); + Asynchronous_Node : constant Node_Id := + New_Occurrence_Of (Standard_False, Loc); + + begin + -- Declare the asynchronous flag. This flag will be changed to True + -- whenever it is known that the RACW type is asynchronous. Also, the + -- node gets stored since it may be rewritten when we process the + -- asynchronous pragma. + + Append_To (Declarations, + Make_Object_Declaration (Loc, + Defining_Identifier => Asynchronous_Flag, + Constant_Present => True, + Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc), + Expression => Asynchronous_Node)); + + Asynchronous_Flags_Table.Set (RACW_Type, Asynchronous_Node); + + -- Object declarations + + Decls := New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => Source_Partition, + Object_Definition => + New_Occurrence_Of (RTE (RE_Partition_ID), Loc)), + + Make_Object_Declaration (Loc, + Defining_Identifier => Source_Receiver, + Object_Definition => + New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)), + + Make_Object_Declaration (Loc, + Defining_Identifier => Source_Address, + Object_Definition => + New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)), + + Make_Object_Declaration (Loc, + Defining_Identifier => Stubbed_Result, + Object_Definition => + New_Occurrence_Of (Stub_Type_Access, Loc))); + + -- Read the source Partition_ID and RPC_Receiver from incoming stream + + Statements := New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (RTE (RE_Partition_ID), Loc), + Attribute_Name => Name_Read, + Expressions => New_List ( + New_Occurrence_Of (Stream_Parameter, Loc), + New_Occurrence_Of (Source_Partition, Loc))), + + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (RTE (RE_Unsigned_64), Loc), + Attribute_Name => + Name_Read, + Expressions => New_List ( + New_Occurrence_Of (Stream_Parameter, Loc), + New_Occurrence_Of (Source_Receiver, Loc))), + + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (RTE (RE_Unsigned_64), Loc), + Attribute_Name => + Name_Read, + Expressions => New_List ( + New_Occurrence_Of (Stream_Parameter, Loc), + New_Occurrence_Of (Source_Address, Loc)))); + + -- If the Address is Null_Address, then return a null object + + Append_To (Statements, + Make_Implicit_If_Statement (RACW_Type, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => New_Occurrence_Of (Source_Address, Loc), + Right_Opnd => Make_Integer_Literal (Loc, Uint_0)), + Then_Statements => New_List ( + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Result, Loc), + Expression => Make_Null (Loc)), + Make_Return_Statement (Loc)))); + + -- If the RACW denotes an object created on the current partition, then + -- Local_Statements will be executed. The real object will be used. + + Local_Statements := New_List ( + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Result, Loc), + Expression => + Unchecked_Convert_To (RACW_Type, + OK_Convert_To (RTE (RE_Address), + New_Occurrence_Of (Source_Address, Loc))))); + + -- If the object is located on another partition, then a stub object + -- will be created with all the information needed to rebuild the + -- real object at the other end. + + Remote_Statements := New_List ( + + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Stubbed_Result, Loc), + Expression => + Make_Allocator (Loc, + New_Occurrence_Of (Stub_Type, Loc))), + + Make_Assignment_Statement (Loc, + Name => Make_Selected_Component (Loc, + Prefix => New_Occurrence_Of (Stubbed_Result, Loc), + Selector_Name => Make_Identifier (Loc, Name_Origin)), + Expression => + New_Occurrence_Of (Source_Partition, Loc)), + + Make_Assignment_Statement (Loc, + Name => Make_Selected_Component (Loc, + Prefix => New_Occurrence_Of (Stubbed_Result, Loc), + Selector_Name => Make_Identifier (Loc, Name_Receiver)), + Expression => + New_Occurrence_Of (Source_Receiver, Loc)), + + Make_Assignment_Statement (Loc, + Name => Make_Selected_Component (Loc, + Prefix => New_Occurrence_Of (Stubbed_Result, Loc), + Selector_Name => Make_Identifier (Loc, Name_Addr)), + Expression => + New_Occurrence_Of (Source_Address, Loc))); + + Append_To (Remote_Statements, + Make_Assignment_Statement (Loc, + Name => Make_Selected_Component (Loc, + Prefix => New_Occurrence_Of (Stubbed_Result, Loc), + Selector_Name => Make_Identifier (Loc, Name_Asynchronous)), + Expression => + New_Occurrence_Of (Asynchronous_Flag, Loc))); + + Append_To (Remote_Statements, + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Get_Unique_Remote_Pointer), Loc), + Parameter_Associations => New_List ( + Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access), + New_Occurrence_Of (Stubbed_Result, Loc))))); + + Append_To (Remote_Statements, + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Result, Loc), + Expression => Unchecked_Convert_To (RACW_Type, + New_Occurrence_Of (Stubbed_Result, Loc)))); + + -- Distinguish between the local and remote cases, and execute the + -- appropriate piece of code. + + Append_To (Statements, + Make_Implicit_If_Statement (RACW_Type, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (RTE (RE_Get_Local_Partition_Id), Loc)), + Right_Opnd => New_Occurrence_Of (Source_Partition, Loc)), + Then_Statements => Local_Statements, + Else_Statements => Remote_Statements)); + + Proc_Spec := + Make_Procedure_Specification (Loc, + Defining_Unit_Name => + Make_Defining_Identifier (Loc, Procedure_Name), + + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Stream_Parameter, + Parameter_Type => + Make_Access_Definition (Loc, + Subtype_Mark => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (RTE (RE_Root_Stream_Type), Loc), + Attribute_Name => + Name_Class))), + + Make_Parameter_Specification (Loc, + Defining_Identifier => Result, + Out_Present => True, + Parameter_Type => + New_Occurrence_Of (RACW_Type, Loc)))); + + Proc_Body_Spec := + Make_Procedure_Specification (Loc, + Defining_Unit_Name => + Make_Defining_Identifier (Loc, Procedure_Name), + + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Chars (Stream_Parameter)), + Parameter_Type => + Make_Access_Definition (Loc, + Subtype_Mark => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (RTE (RE_Root_Stream_Type), Loc), + Attribute_Name => + Name_Class))), + + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Chars (Result)), + Out_Present => True, + Parameter_Type => + New_Occurrence_Of (RACW_Type, Loc)))); + + Body_Node := + Make_Subprogram_Body (Loc, + Specification => Proc_Body_Spec, + Declarations => Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Statements)); + + Proc_Decl := + Make_Subprogram_Declaration (Loc, Specification => Proc_Spec); + + Attr_Decl := + Make_Attribute_Definition_Clause (Loc, + Name => New_Occurrence_Of (RACW_Type, Loc), + Chars => Name_Read, + Expression => + New_Occurrence_Of (Defining_Unit_Name (Proc_Spec), Loc)); + + Insert_After (Declaration_Node (RACW_Type), Proc_Decl); + Insert_After (Proc_Decl, Attr_Decl); + Append_To (Declarations, Body_Node); + end Add_RACW_Read_Attribute; + + ------------------------------------ + -- Add_RACW_Read_Write_Attributes -- + ------------------------------------ + + procedure Add_RACW_Read_Write_Attributes + (RACW_Type : in Entity_Id; + Stub_Type : in Entity_Id; + Stub_Type_Access : in Entity_Id; + Object_RPC_Receiver : in Entity_Id; + Declarations : in List_Id) + is + begin + Add_RACW_Write_Attribute + (RACW_Type => RACW_Type, + Stub_Type => Stub_Type, + Stub_Type_Access => Stub_Type_Access, + Object_RPC_Receiver => Object_RPC_Receiver, + Declarations => Declarations); + + Add_RACW_Read_Attribute + (RACW_Type => RACW_Type, + Stub_Type => Stub_Type, + Stub_Type_Access => Stub_Type_Access, + Declarations => Declarations); + end Add_RACW_Read_Write_Attributes; + + ------------------------------ + -- Add_RACW_Write_Attribute -- + ------------------------------ + + procedure Add_RACW_Write_Attribute + (RACW_Type : in Entity_Id; + Stub_Type : in Entity_Id; + Stub_Type_Access : in Entity_Id; + Object_RPC_Receiver : in Entity_Id; + Declarations : in List_Id) + is + Loc : constant Source_Ptr := Sloc (RACW_Type); + + Proc_Spec : Node_Id; + + Proc_Body_Spec : Node_Id; + + Body_Node : Node_Id; + + Proc_Decl : Node_Id; + Attr_Decl : Node_Id; + + Statements : List_Id; + Local_Statements : List_Id; + Remote_Statements : List_Id; + Null_Statements : List_Id; + + Procedure_Name : constant Name_Id := New_Internal_Name ('R'); + + Stream_Parameter : constant Entity_Id := + Make_Defining_Identifier + (Loc, New_Internal_Name ('S')); + + Object : constant Entity_Id := + Make_Defining_Identifier (Loc, New_Internal_Name ('P')); + + begin + -- Build the code fragment corresponding to the marshalling of a + -- local object. + + Local_Statements := New_List ( + + Pack_Entity_Into_Stream_Access (Loc, + Stream => Stream_Parameter, + Object => RTE (RE_Get_Local_Partition_Id)), + + Pack_Node_Into_Stream_Access (Loc, + Stream => Stream_Parameter, + Object => OK_Convert_To (RTE (RE_Unsigned_64), + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Object_RPC_Receiver, Loc), + Attribute_Name => Name_Address)), + Etyp => RTE (RE_Unsigned_64)), + + Pack_Node_Into_Stream_Access (Loc, + Stream => Stream_Parameter, + Object => OK_Convert_To (RTE (RE_Unsigned_64), + Make_Attribute_Reference (Loc, + Prefix => + Make_Explicit_Dereference (Loc, + Prefix => New_Occurrence_Of (Object, Loc)), + Attribute_Name => Name_Address)), + Etyp => RTE (RE_Unsigned_64))); + + -- Build the code fragment corresponding to the marshalling of + -- a remote object. + + Remote_Statements := New_List ( + + Pack_Node_Into_Stream_Access (Loc, + Stream => Stream_Parameter, + Object => + Make_Selected_Component (Loc, + Prefix => Unchecked_Convert_To (Stub_Type_Access, + New_Occurrence_Of (Object, Loc)), + Selector_Name => + Make_Identifier (Loc, Name_Origin)), + Etyp => RTE (RE_Partition_ID)), + + Pack_Node_Into_Stream_Access (Loc, + Stream => Stream_Parameter, + Object => + Make_Selected_Component (Loc, + Prefix => Unchecked_Convert_To (Stub_Type_Access, + New_Occurrence_Of (Object, Loc)), + Selector_Name => + Make_Identifier (Loc, Name_Receiver)), + Etyp => RTE (RE_Unsigned_64)), + + Pack_Node_Into_Stream_Access (Loc, + Stream => Stream_Parameter, + Object => + Make_Selected_Component (Loc, + Prefix => Unchecked_Convert_To (Stub_Type_Access, + New_Occurrence_Of (Object, Loc)), + Selector_Name => + Make_Identifier (Loc, Name_Addr)), + Etyp => RTE (RE_Unsigned_64))); + + -- Build the code fragment corresponding to the marshalling of a null + -- object. + + Null_Statements := New_List ( + + Pack_Entity_Into_Stream_Access (Loc, + Stream => Stream_Parameter, + Object => RTE (RE_Get_Local_Partition_Id)), + + Pack_Node_Into_Stream_Access (Loc, + Stream => Stream_Parameter, + Object => OK_Convert_To (RTE (RE_Unsigned_64), + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Object_RPC_Receiver, Loc), + Attribute_Name => Name_Address)), + Etyp => RTE (RE_Unsigned_64)), + + Pack_Node_Into_Stream_Access (Loc, + Stream => Stream_Parameter, + Object => Make_Integer_Literal (Loc, Uint_0), + Etyp => RTE (RE_Unsigned_64))); + + Statements := New_List ( + Make_Implicit_If_Statement (RACW_Type, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => New_Occurrence_Of (Object, Loc), + Right_Opnd => Make_Null (Loc)), + Then_Statements => Null_Statements, + Elsif_Parts => New_List ( + Make_Elsif_Part (Loc, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Object, Loc), + Attribute_Name => Name_Tag), + Right_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Stub_Type, Loc), + Attribute_Name => Name_Tag)), + Then_Statements => Remote_Statements)), + Else_Statements => Local_Statements)); + + Proc_Spec := + Make_Procedure_Specification (Loc, + Defining_Unit_Name => + Make_Defining_Identifier (Loc, Procedure_Name), + + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Stream_Parameter, + Parameter_Type => + Make_Access_Definition (Loc, + Subtype_Mark => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (RTE (RE_Root_Stream_Type), Loc), + Attribute_Name => + Name_Class))), + + Make_Parameter_Specification (Loc, + Defining_Identifier => Object, + In_Present => True, + Parameter_Type => + New_Occurrence_Of (RACW_Type, Loc)))); + + Proc_Decl := + Make_Subprogram_Declaration (Loc, Specification => Proc_Spec); + + Attr_Decl := + Make_Attribute_Definition_Clause (Loc, + Name => New_Occurrence_Of (RACW_Type, Loc), + Chars => Name_Write, + Expression => + New_Occurrence_Of (Defining_Unit_Name (Proc_Spec), Loc)); + + Proc_Body_Spec := + Make_Procedure_Specification (Loc, + Defining_Unit_Name => + Make_Defining_Identifier (Loc, Procedure_Name), + + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Chars (Stream_Parameter)), + Parameter_Type => + Make_Access_Definition (Loc, + Subtype_Mark => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (RTE (RE_Root_Stream_Type), Loc), + Attribute_Name => + Name_Class))), + + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Chars (Object)), + In_Present => True, + Parameter_Type => + New_Occurrence_Of (RACW_Type, Loc)))); + + Body_Node := + Make_Subprogram_Body (Loc, + Specification => Proc_Body_Spec, + Declarations => No_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Statements)); + + Insert_After (Declaration_Node (RACW_Type), Proc_Decl); + Insert_After (Proc_Decl, Attr_Decl); + Append_To (Declarations, Body_Node); + end Add_RACW_Write_Attribute; + + ------------------------------ + -- Add_RAS_Access_Attribute -- + ------------------------------ + + procedure Add_RAS_Access_Attribute (N : in Node_Id) is + Ras_Type : constant Entity_Id := Defining_Identifier (N); + Fat_Type : constant Entity_Id := Equivalent_Type (Ras_Type); + -- Ras_Type is the access to subprogram type while Fat_Type points to + -- the record type corresponding to a remote access to subprogram type. + + Proc_Decls : constant List_Id := New_List; + Proc_Statements : constant List_Id := New_List; + + Proc_Spec : Node_Id; + Proc_Body : Node_Id; + + Proc : Node_Id; + + Param : Node_Id; + Package_Name : Node_Id; + Subp_Id : Node_Id; + Asynchronous : Node_Id; + Return_Value : Node_Id; + + Loc : constant Source_Ptr := Sloc (N); + + procedure Set_Field (Field_Name : in Name_Id; Value : in Node_Id); + -- Set a field name for the return value + + procedure Set_Field (Field_Name : in Name_Id; Value : in Node_Id) + is + begin + Append_To (Proc_Statements, + Make_Assignment_Statement (Loc, + Name => + Make_Selected_Component (Loc, + Prefix => New_Occurrence_Of (Return_Value, Loc), + Selector_Name => Make_Identifier (Loc, Field_Name)), + Expression => Value)); + end Set_Field; + + -- Start of processing for Add_RAS_Access_Attribute + + begin + Param := Make_Defining_Identifier (Loc, New_Internal_Name ('P')); + Package_Name := Make_Defining_Identifier (Loc, New_Internal_Name ('S')); + Subp_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('N')); + Asynchronous := Make_Defining_Identifier (Loc, New_Internal_Name ('B')); + Return_Value := Make_Defining_Identifier (Loc, New_Internal_Name ('P')); + + -- Create the object which will be returned of type Fat_Type + + Append_To (Proc_Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Return_Value, + Object_Definition => + New_Occurrence_Of (Fat_Type, Loc))); + + -- Initialize the fields of the record type with the appropriate data + + Set_Field (Name_Ras, + OK_Convert_To (RTE (RE_Unsigned_64), New_Occurrence_Of (Param, Loc))); + + Set_Field (Name_Origin, + Unchecked_Convert_To (Standard_Integer, + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (RTE (RE_Get_Active_Partition_Id), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Package_Name, Loc))))); + + Set_Field (Name_Receiver, + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (RTE (RE_Get_RCI_Package_Receiver), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Package_Name, Loc)))); + + Set_Field (Name_Subp_Id, + New_Occurrence_Of (Subp_Id, Loc)); + + Set_Field (Name_Async, + New_Occurrence_Of (Asynchronous, Loc)); + + -- Return the newly created value + + Append_To (Proc_Statements, + Make_Return_Statement (Loc, + Expression => + New_Occurrence_Of (Return_Value, Loc))); + + Proc := Make_Defining_Identifier (Loc, Name_uRAS_Access); + + Proc_Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => Proc, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Param, + Parameter_Type => + New_Occurrence_Of (RTE (RE_Address), Loc)), + + Make_Parameter_Specification (Loc, + Defining_Identifier => Package_Name, + Parameter_Type => + New_Occurrence_Of (Standard_String, Loc)), + + Make_Parameter_Specification (Loc, + Defining_Identifier => Subp_Id, + Parameter_Type => + New_Occurrence_Of (Standard_Natural, Loc)), + + Make_Parameter_Specification (Loc, + Defining_Identifier => Asynchronous, + Parameter_Type => + New_Occurrence_Of (Standard_Boolean, Loc))), + + Subtype_Mark => + New_Occurrence_Of (Fat_Type, Loc)); + + -- Set the kind and return type of the function to prevent ambiguities + -- between Ras_Type and Fat_Type in subsequent analysis. + + Set_Ekind (Proc, E_Function); + Set_Etype (Proc, New_Occurrence_Of (Fat_Type, Loc)); + + Proc_Body := + Make_Subprogram_Body (Loc, + Specification => Proc_Spec, + Declarations => Proc_Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Proc_Statements)); + + Set_TSS (Fat_Type, Proc); + + end Add_RAS_Access_Attribute; + + ----------------------------------- + -- Add_RAS_Dereference_Attribute -- + ----------------------------------- + + procedure Add_RAS_Dereference_Attribute (N : in Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + + Type_Def : constant Node_Id := Type_Definition (N); + + Ras_Type : constant Entity_Id := Defining_Identifier (N); + + Fat_Type : constant Entity_Id := Equivalent_Type (Ras_Type); + + Proc_Decls : constant List_Id := New_List; + Proc_Statements : constant List_Id := New_List; + + Inner_Decls : constant List_Id := New_List; + Inner_Statements : constant List_Id := New_List; + + Direct_Statements : constant List_Id := New_List; + + Proc : Node_Id; + + Proc_Spec : Node_Id; + Proc_Body : Node_Id; + + Param_Specs : constant List_Id := New_List; + Param_Assoc : constant List_Id := New_List; + + Pointer : Node_Id; + + Converted_Ras : Node_Id; + Target_Partition : Node_Id; + RPC_Receiver : Node_Id; + Subprogram_Id : Node_Id; + Asynchronous : Node_Id; + + Is_Function : constant Boolean := + Nkind (Type_Def) = N_Access_Function_Definition; + + Spec : constant Node_Id := Type_Def; + + Current_Parameter : Node_Id; + + begin + -- The way to do it is test if the Ras field is non-null and then if + -- the Origin field is equal to the current partition ID (which is in + -- fact Current_Package'Partition_ID). If this is the case, then it + -- is safe to dereference the Ras field directly rather than + -- performing a remote call. + + Pointer := + Make_Defining_Identifier (Loc, New_Internal_Name ('P')); + + Target_Partition := + Make_Defining_Identifier (Loc, New_Internal_Name ('P')); + + Append_To (Proc_Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Target_Partition, + Constant_Present => True, + Object_Definition => + New_Occurrence_Of (RTE (RE_Partition_ID), Loc), + Expression => + Unchecked_Convert_To (RTE (RE_Partition_ID), + Make_Selected_Component (Loc, + Prefix => + New_Occurrence_Of (Pointer, Loc), + Selector_Name => + Make_Identifier (Loc, Name_Origin))))); + + RPC_Receiver := + Make_Selected_Component (Loc, + Prefix => + New_Occurrence_Of (Pointer, Loc), + Selector_Name => + Make_Identifier (Loc, Name_Receiver)); + + Subprogram_Id := + Unchecked_Convert_To (RTE (RE_Subprogram_Id), + Make_Selected_Component (Loc, + Prefix => + New_Occurrence_Of (Pointer, Loc), + Selector_Name => + Make_Identifier (Loc, Name_Subp_Id))); + + -- A function is never asynchronous. A procedure may or may not be + -- asynchronous depending on whether a pragma Asynchronous applies + -- on it. Since a RAST may point onto various subprograms, this is + -- only known at runtime so both versions (synchronous and asynchronous) + -- must be built every times it is not a function. + + if Is_Function then + Asynchronous := Empty; + + else + Asynchronous := + Make_Selected_Component (Loc, + Prefix => + New_Occurrence_Of (Pointer, Loc), + Selector_Name => + Make_Identifier (Loc, Name_Async)); + + end if; + + if Present (Parameter_Specifications (Type_Def)) then + Current_Parameter := First (Parameter_Specifications (Type_Def)); + + while Current_Parameter /= Empty loop + Append_To (Param_Specs, + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, + Chars => Chars (Defining_Identifier (Current_Parameter))), + In_Present => In_Present (Current_Parameter), + Out_Present => Out_Present (Current_Parameter), + Parameter_Type => + New_Occurrence_Of + (Etype (Parameter_Type (Current_Parameter)), Loc), + Expression => + New_Copy_Tree (Expression (Current_Parameter)))); + + Append_To (Param_Assoc, + Make_Identifier (Loc, + Chars => Chars (Defining_Identifier (Current_Parameter)))); + + Next (Current_Parameter); + end loop; + end if; + + Proc := Make_Defining_Identifier (Loc, Name_uRAS_Dereference); + + if Is_Function then + Proc_Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => Proc, + Parameter_Specifications => Param_Specs, + Subtype_Mark => + New_Occurrence_Of ( + Entity (Subtype_Mark (Spec)), Loc)); + + Set_Ekind (Proc, E_Function); + + Set_Etype (Proc, + New_Occurrence_Of (Entity (Subtype_Mark (Spec)), Loc)); + + else + Proc_Spec := + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Proc, + Parameter_Specifications => Param_Specs); + + Set_Ekind (Proc, E_Procedure); + Set_Etype (Proc, Standard_Void_Type); + end if; + + -- Build the calling stubs for the dereference of the RAS + + Build_General_Calling_Stubs + (Decls => Inner_Decls, + Statements => Inner_Statements, + Target_Partition => Target_Partition, + RPC_Receiver => RPC_Receiver, + Subprogram_Id => Subprogram_Id, + Asynchronous => Asynchronous, + Is_Known_Non_Asynchronous => Is_Function, + Is_Function => Is_Function, + Spec => Proc_Spec, + Nod => N); + + Converted_Ras := + Unchecked_Convert_To (Ras_Type, + OK_Convert_To (RTE (RE_Address), + Make_Selected_Component (Loc, + Prefix => New_Occurrence_Of (Pointer, Loc), + Selector_Name => Make_Identifier (Loc, Name_Ras)))); + + if Is_Function then + Append_To (Direct_Statements, + Make_Return_Statement (Loc, + Expression => + Make_Function_Call (Loc, + Name => + Make_Explicit_Dereference (Loc, + Prefix => Converted_Ras), + Parameter_Associations => Param_Assoc))); + + else + Append_To (Direct_Statements, + Make_Procedure_Call_Statement (Loc, + Name => + Make_Explicit_Dereference (Loc, + Prefix => Converted_Ras), + Parameter_Associations => Param_Assoc)); + end if; + + Prepend_To (Param_Specs, + Make_Parameter_Specification (Loc, + Defining_Identifier => Pointer, + In_Present => True, + Parameter_Type => + New_Occurrence_Of (Fat_Type, Loc))); + + Append_To (Proc_Statements, + Make_Implicit_If_Statement (N, + Condition => + Make_And_Then (Loc, + Left_Opnd => + Make_Op_Ne (Loc, + Left_Opnd => + Make_Selected_Component (Loc, + Prefix => New_Occurrence_Of (Pointer, Loc), + Selector_Name => Make_Identifier (Loc, Name_Ras)), + Right_Opnd => + Make_Integer_Literal (Loc, Uint_0)), + + Right_Opnd => + Make_Op_Eq (Loc, + Left_Opnd => + New_Occurrence_Of (Target_Partition, Loc), + Right_Opnd => + Make_Function_Call (Loc, + New_Occurrence_Of ( + RTE (RE_Get_Local_Partition_Id), Loc)))), + + Then_Statements => + Direct_Statements, + + Else_Statements => New_List ( + Make_Block_Statement (Loc, + Declarations => Inner_Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Inner_Statements))))); + + Proc_Body := + Make_Subprogram_Body (Loc, + Specification => Proc_Spec, + Declarations => Proc_Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Proc_Statements)); + + Set_TSS (Fat_Type, Defining_Unit_Name (Proc_Spec)); + + end Add_RAS_Dereference_Attribute; + + ----------------------- + -- Add_RAST_Features -- + ----------------------- + + procedure Add_RAST_Features (Vis_Decl : Node_Id) is + begin + -- Do not add attributes more than once in any case. This should + -- be replaced by an assert or this comment removed if we decide + -- that this is normal to be called several times ??? + + if Present (TSS (Equivalent_Type (Defining_Identifier + (Vis_Decl)), Name_uRAS_Access)) + then + return; + end if; + + Add_RAS_Dereference_Attribute (Vis_Decl); + Add_RAS_Access_Attribute (Vis_Decl); + end Add_RAST_Features; + + ----------------------------------------- + -- Add_Receiving_Stubs_To_Declarations -- + ----------------------------------------- + + procedure Add_Receiving_Stubs_To_Declarations + (Pkg_Spec : in Node_Id; + Decls : in List_Id) + is + Loc : constant Source_Ptr := Sloc (Pkg_Spec); + + Stream_Parameter : Node_Id; + Result_Parameter : Node_Id; + + Pkg_RPC_Receiver : Node_Id; + Pkg_RPC_Receiver_Spec : Node_Id; + Pkg_RPC_Receiver_Formals : List_Id; + Pkg_RPC_Receiver_Decls : List_Id; + Pkg_RPC_Receiver_Statements : List_Id; + Pkg_RPC_Receiver_Cases : List_Id := New_List; + Pkg_RPC_Receiver_Body : Node_Id; + -- A Pkg_RPC_Receiver is built to decode the request + + Subp_Id : Node_Id; + -- Subprogram_Id as read from the incoming stream + + Current_Declaration : Node_Id; + Current_Subprogram_Number : Int := 0; + Current_Stubs : Node_Id; + + Actuals : List_Id; + + Dummy_Register_Name : Name_Id; + Dummy_Register_Spec : Node_Id; + Dummy_Register_Decl : Node_Id; + Dummy_Register_Body : Node_Id; + + begin + -- Building receiving stubs consist in several operations: + + -- - a package RPC receiver must be built. This subprogram + -- will get a Subprogram_Id from the incoming stream + -- and will dispatch the call to the right subprogram + + -- - a receiving stub for any subprogram visible in the package + -- spec. This stub will read all the parameters from the stream, + -- and put the result as well as the exception occurrence in the + -- output stream + + -- - a dummy package with an empty spec and a body made of an + -- elaboration part, whose job is to register the receiving + -- part of this RCI package on the name server. This is done + -- by calling System.Partition_Interface.Register_Receiving_Stub + + Stream_Parameter := + Make_Defining_Identifier (Loc, New_Internal_Name ('S')); + Result_Parameter := + Make_Defining_Identifier (Loc, New_Internal_Name ('R')); + Subp_Id := + Make_Defining_Identifier (Loc, New_Internal_Name ('P')); + + Pkg_RPC_Receiver := + Make_Defining_Identifier (Loc, New_Internal_Name ('P')); + + -- The parameters of the package RPC receiver are made of two + -- streams, an input one and an output one. + + Pkg_RPC_Receiver_Formals := New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Stream_Parameter, + Parameter_Type => + Make_Access_Definition (Loc, + Subtype_Mark => + New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc))), + Make_Parameter_Specification (Loc, + Defining_Identifier => Result_Parameter, + Parameter_Type => + Make_Access_Definition (Loc, + Subtype_Mark => + New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc)))); + + Pkg_RPC_Receiver_Spec := + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Pkg_RPC_Receiver, + Parameter_Specifications => Pkg_RPC_Receiver_Formals); + + Pkg_RPC_Receiver_Decls := New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => Subp_Id, + Object_Definition => + New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc))); + + Pkg_RPC_Receiver_Statements := New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc), + Attribute_Name => + Name_Read, + Expressions => New_List ( + New_Occurrence_Of (Stream_Parameter, Loc), + New_Occurrence_Of (Subp_Id, 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. + + Current_Declaration := First (Visible_Declarations (Pkg_Spec)); + + while Current_Declaration /= Empty loop + + if Nkind (Current_Declaration) = N_Subprogram_Declaration + and then Comes_From_Source (Current_Declaration) + then + pragma Assert (Current_Subprogram_Number = + Get_Subprogram_Id (Defining_Unit_Name (Specification ( + Current_Declaration)))); + + Current_Stubs := + Build_Subprogram_Receiving_Stubs + (Vis_Decl => Current_Declaration, + Asynchronous => + Nkind (Specification (Current_Declaration)) = + N_Procedure_Specification + and then Is_Asynchronous + (Defining_Unit_Name (Specification + (Current_Declaration)))); + + Append_To (Decls, Current_Stubs); + + Analyze (Current_Stubs); + + Actuals := New_List (New_Occurrence_Of (Stream_Parameter, Loc)); + + if Nkind (Specification (Current_Declaration)) + = N_Function_Specification + or else + not Is_Asynchronous ( + Defining_Entity (Specification (Current_Declaration))) + then + -- An asynchronous procedure does not want an output parameter + -- since no result and no exception will ever be returned. + + Append_To (Actuals, + New_Occurrence_Of (Result_Parameter, Loc)); + + end if; + + Append_To (Pkg_RPC_Receiver_Cases, + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => + New_List ( + Make_Integer_Literal (Loc, Current_Subprogram_Number)), + + Statements => + New_List ( + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of ( + Defining_Entity (Current_Stubs), Loc), + Parameter_Associations => + Actuals)))); + + Current_Subprogram_Number := Current_Subprogram_Number + 1; + end if; + + Next (Current_Declaration); + end loop; + + -- If we receive an invalid Subprogram_Id, it is best to do nothing + -- rather than raising an exception since we do not want someone + -- to crash a remote partition by sending invalid subprogram ids. + -- This is consistent with the other parts of the case statement + -- since even in presence of incorrect parameters in the stream, + -- every exception will be caught and (if the subprogram is not an + -- APC) put into the result stream and sent away. + + Append_To (Pkg_RPC_Receiver_Cases, + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => + New_List (Make_Others_Choice (Loc)), + Statements => + New_List (Make_Null_Statement (Loc)))); + + Append_To (Pkg_RPC_Receiver_Statements, + Make_Case_Statement (Loc, + Expression => + New_Occurrence_Of (Subp_Id, Loc), + Alternatives => Pkg_RPC_Receiver_Cases)); + + Pkg_RPC_Receiver_Body := + Make_Subprogram_Body (Loc, + Specification => Pkg_RPC_Receiver_Spec, + Declarations => Pkg_RPC_Receiver_Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Pkg_RPC_Receiver_Statements)); + + Append_To (Decls, Pkg_RPC_Receiver_Body); + Analyze (Pkg_RPC_Receiver_Body); + + -- Construction of the dummy package used to register the package + -- receiving stubs on the nameserver. + + Dummy_Register_Name := New_Internal_Name ('P'); + + Dummy_Register_Spec := + Make_Package_Specification (Loc, + Defining_Unit_Name => + Make_Defining_Identifier (Loc, Dummy_Register_Name), + Visible_Declarations => No_List, + End_Label => Empty); + + Dummy_Register_Decl := + Make_Package_Declaration (Loc, + Specification => Dummy_Register_Spec); + + Append_To (Decls, + Dummy_Register_Decl); + Analyze (Dummy_Register_Decl); + + Dummy_Register_Body := + Make_Package_Body (Loc, + Defining_Unit_Name => + Make_Defining_Identifier (Loc, Dummy_Register_Name), + Declarations => No_List, + + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Register_Receiving_Stub), Loc), + + Parameter_Associations => New_List ( + Make_String_Literal (Loc, + Strval => Get_Pkg_Name_String_Id (Pkg_Spec)), + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Pkg_RPC_Receiver, Loc), + Attribute_Name => + Name_Unrestricted_Access), + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc), + Attribute_Name => + Name_Version)))))); + + Append_To (Decls, Dummy_Register_Body); + Analyze (Dummy_Register_Body); + end Add_Receiving_Stubs_To_Declarations; + + ------------------- + -- Add_Stub_Type -- + ------------------- + + procedure Add_Stub_Type + (Designated_Type : in Entity_Id; + RACW_Type : in Entity_Id; + Decls : in List_Id; + Stub_Type : out Entity_Id; + Stub_Type_Access : out Entity_Id; + Object_RPC_Receiver : out Entity_Id; + Existing : out Boolean) + is + Loc : constant Source_Ptr := Sloc (RACW_Type); + + Stub_Elements : constant Stub_Structure := + Stubs_Table.Get (Designated_Type); + + Stub_Type_Declaration : Node_Id; + Stub_Type_Access_Declaration : Node_Id; + Object_RPC_Receiver_Declaration : Node_Id; + + RPC_Receiver_Stream : Entity_Id; + RPC_Receiver_Result : Entity_Id; + + begin + if Stub_Elements /= Empty_Stub_Structure then + Stub_Type := Stub_Elements.Stub_Type; + Stub_Type_Access := Stub_Elements.Stub_Type_Access; + Object_RPC_Receiver := Stub_Elements.Object_RPC_Receiver; + Existing := True; + return; + end if; + + Existing := False; + Stub_Type := + Make_Defining_Identifier (Loc, New_Internal_Name ('S')); + Stub_Type_Access := + Make_Defining_Identifier (Loc, New_Internal_Name ('S')); + Object_RPC_Receiver := + Make_Defining_Identifier (Loc, New_Internal_Name ('P')); + RPC_Receiver_Stream := + Make_Defining_Identifier (Loc, New_Internal_Name ('S')); + RPC_Receiver_Result := + Make_Defining_Identifier (Loc, New_Internal_Name ('S')); + Stubs_Table.Set (Designated_Type, + (Stub_Type => Stub_Type, + Stub_Type_Access => Stub_Type_Access, + Object_RPC_Receiver => Object_RPC_Receiver, + RPC_Receiver_Stream => RPC_Receiver_Stream, + RPC_Receiver_Result => RPC_Receiver_Result, + RACW_Type => RACW_Type)); + + -- The stub type definition below must match exactly the one in + -- s-parint.ads, since unchecked conversions will be used in + -- s-parint.adb to modify pointers passed to Get_Unique_Remote_Pointer. + + Stub_Type_Declaration := + 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), + Subtype_Indication => + New_Occurrence_Of (RTE (RE_Partition_ID), Loc)), + + Make_Component_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_Receiver), + Subtype_Indication => + New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)), + + Make_Component_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_Addr), + Subtype_Indication => + New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)), + + Make_Component_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_Asynchronous), + Subtype_Indication => + New_Occurrence_Of (Standard_Boolean, Loc)))))); + + Append_To (Decls, Stub_Type_Declaration); + Analyze (Stub_Type_Declaration); + + -- This is in no way a type derivation, but we fake it to make + -- sure that the dispatching table gets built with the corresponding + -- primitive operations at the right place. + + Derive_Subprograms (Parent_Type => Designated_Type, + Derived_Type => Stub_Type); + + Stub_Type_Access_Declaration := + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Stub_Type_Access, + Type_Definition => + Make_Access_To_Object_Definition (Loc, + Subtype_Indication => New_Occurrence_Of (Stub_Type, Loc))); + + Append_To (Decls, Stub_Type_Access_Declaration); + Analyze (Stub_Type_Access_Declaration); + + Object_RPC_Receiver_Declaration := + Make_Subprogram_Declaration (Loc, + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Object_RPC_Receiver, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => RPC_Receiver_Stream, + Parameter_Type => + Make_Access_Definition (Loc, + Subtype_Mark => + New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc))), + + Make_Parameter_Specification (Loc, + Defining_Identifier => RPC_Receiver_Result, + Parameter_Type => + Make_Access_Definition (Loc, + Subtype_Mark => + New_Occurrence_Of + (RTE (RE_Params_Stream_Type), Loc)))))); + + Append_To (Decls, Object_RPC_Receiver_Declaration); + end Add_Stub_Type; + + --------------------------------- + -- Build_General_Calling_Stubs -- + --------------------------------- + + procedure Build_General_Calling_Stubs + (Decls : List_Id; + Statements : List_Id; + Target_Partition : Entity_Id; + RPC_Receiver : Node_Id; + Subprogram_Id : Node_Id; + Asynchronous : Node_Id := Empty; + Is_Known_Asynchronous : Boolean := False; + Is_Known_Non_Asynchronous : Boolean := False; + Is_Function : Boolean; + Spec : Node_Id; + Object_Type : Entity_Id := Empty; + Nod : Node_Id) + is + Loc : constant Source_Ptr := Sloc (Nod); + + Stream_Parameter : Node_Id; + -- Name of the stream used to transmit parameters to the remote package + + Result_Parameter : Node_Id; + -- Name of the result parameter (in non-APC cases) which get the + -- result of the remote subprogram. + + Exception_Return_Parameter : Node_Id; + -- Name of the parameter which will hold the exception sent by the + -- remote subprogram. + + Current_Parameter : Node_Id; + -- Current parameter being handled + + Ordered_Parameters_List : constant List_Id := + Build_Ordered_Parameters_List (Spec); + + Asynchronous_Statements : List_Id := No_List; + Non_Asynchronous_Statements : List_Id := No_List; + -- Statements specifics to the Asynchronous/Non-Asynchronous cases. + + Extra_Formal_Statements : constant List_Id := New_List; + -- List of statements for extra formal parameters. It will appear after + -- the regular statements for writing out parameters. + + begin + -- The general form of a calling stub for a given subprogram is: + + -- procedure X (...) is + -- P : constant Partition_ID := RCI_Cache.Get_Active_Partition_ID; + -- Stream, Result : aliased System.RPC.Params_Stream_Type (0); + -- begin + -- Put_Package_RPC_Receiver_In_Stream; (the package RPC receiver + -- comes from RCI_Cache.Get_RCI_Package_Receiver) + -- Put_Subprogram_Id_In_Stream; + -- Put_Parameters_In_Stream; + -- Do_RPC (Stream, Result); + -- Read_Exception_Occurrence_From_Result; Raise_It; + -- Read_Out_Parameters_And_Function_Return_From_Stream; + -- end X; + + -- There are some variations: Do_APC is called for an asynchronous + -- procedure and the part after the call is completely ommitted + -- as well as the declaration of Result. For a function call, + -- 'Input is always used to read the result even if it is constrained. + + Stream_Parameter := + Make_Defining_Identifier (Loc, New_Internal_Name ('S')); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Stream_Parameter, + Aliased_Present => True, + Object_Definition => + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => + New_List (Make_Integer_Literal (Loc, 0)))))); + + if not Is_Known_Asynchronous then + Result_Parameter := + Make_Defining_Identifier (Loc, New_Internal_Name ('R')); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Result_Parameter, + Aliased_Present => True, + Object_Definition => + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => + New_List (Make_Integer_Literal (Loc, 0)))))); + + Exception_Return_Parameter := + Make_Defining_Identifier (Loc, New_Internal_Name ('E')); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Exception_Return_Parameter, + Object_Definition => + New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc))); + + else + Result_Parameter := Empty; + Exception_Return_Parameter := Empty; + end if; + + -- Put first the RPC receiver corresponding to the remote package + + Append_To (Statements, + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (RTE (RE_Unsigned_64), Loc), + Attribute_Name => Name_Write, + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Stream_Parameter, Loc), + Attribute_Name => + Name_Access), + RPC_Receiver))); + + -- Then put the Subprogram_Id of the subprogram we want to call in + -- the stream. + + Append_To (Statements, + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc), + Attribute_Name => + Name_Write, + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Stream_Parameter, Loc), + Attribute_Name => Name_Access), + Subprogram_Id))); + + Current_Parameter := First (Ordered_Parameters_List); + + while Current_Parameter /= Empty loop + + if Is_RACW_Controlling_Formal (Current_Parameter, Object_Type) then + + -- In the case of a controlling formal argument, we marshall + -- its addr field rather than the local stub. + + Append_To (Statements, + Pack_Node_Into_Stream (Loc, + Stream => Stream_Parameter, + Object => + Make_Selected_Component (Loc, + Prefix => + New_Occurrence_Of ( + Defining_Identifier (Current_Parameter), Loc), + Selector_Name => + Make_Identifier (Loc, Name_Addr)), + Etyp => RTE (RE_Unsigned_64))); + + else + declare + Etyp : constant Entity_Id := + Etype (Parameter_Type (Current_Parameter)); + + Constrained : constant Boolean := + Is_Constrained (Etyp) + or else Is_Elementary_Type (Etyp); + + begin + if In_Present (Current_Parameter) + or else not Out_Present (Current_Parameter) + or else not Constrained + then + Append_To (Statements, + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Etyp, Loc), + Attribute_Name => Output_From_Constrained (Constrained), + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Stream_Parameter, Loc), + Attribute_Name => Name_Access), + New_Occurrence_Of ( + Defining_Identifier (Current_Parameter), Loc)))); + end if; + end; + end if; + + -- If the current parameter has a dynamic constrained status, + -- then this status is transmitted as well. + -- This should be done for accessibility as well ??? + + if Nkind (Parameter_Type (Current_Parameter)) /= N_Access_Definition + and then Need_Extra_Constrained (Current_Parameter) + then + -- In this block, we do not use the extra formal that has been + -- created because it does not exist at the time of expansion + -- when building calling stubs for remote access to subprogram + -- types. We create an extra variable of this type and push it + -- in the stream after the regular parameters. + + declare + Extra_Parameter : constant Entity_Id := + Make_Defining_Identifier + (Loc, New_Internal_Name ('P')); + + begin + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Extra_Parameter, + Constant_Present => True, + Object_Definition => + New_Occurrence_Of (Standard_Boolean, Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of ( + Defining_Identifier (Current_Parameter), Loc), + Attribute_Name => Name_Constrained))); + + Append_To (Extra_Formal_Statements, + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Standard_Boolean, Loc), + Attribute_Name => + Name_Write, + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Stream_Parameter, Loc), + Attribute_Name => + Name_Access), + New_Occurrence_Of (Extra_Parameter, Loc)))); + end; + end if; + + Next (Current_Parameter); + end loop; + + -- Append the formal statements list to the statements + + Append_List_To (Statements, Extra_Formal_Statements); + + if not Is_Known_Non_Asynchronous then + + -- Build the call to System.RPC.Do_APC + + Asynchronous_Statements := New_List ( + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Do_Apc), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Target_Partition, Loc), + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Stream_Parameter, Loc), + Attribute_Name => + Name_Access)))); + else + Asynchronous_Statements := No_List; + end if; + + if not Is_Known_Asynchronous then + + -- Build the call to System.RPC.Do_RPC + + Non_Asynchronous_Statements := New_List ( + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Do_Rpc), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Target_Partition, Loc), + + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Stream_Parameter, Loc), + Attribute_Name => + Name_Access), + + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Result_Parameter, Loc), + Attribute_Name => + Name_Access)))); + + -- Read the exception occurrence from the result stream and + -- reraise it. It does no harm if this is a Null_Occurrence since + -- this does nothing. + + Append_To (Non_Asynchronous_Statements, + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc), + + Attribute_Name => + Name_Read, + + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Result_Parameter, Loc), + Attribute_Name => + Name_Access), + New_Occurrence_Of (Exception_Return_Parameter, Loc)))); + + Append_To (Non_Asynchronous_Statements, + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Reraise_Occurrence), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Exception_Return_Parameter, Loc)))); + + if Is_Function then + + -- If this is a function call, then read the value and return + -- it. The return value is written/read using 'Output/'Input. + + Append_To (Non_Asynchronous_Statements, + Make_Tag_Check (Loc, + Make_Return_Statement (Loc, + Expression => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of ( + Etype (Subtype_Mark (Spec)), Loc), + + Attribute_Name => Name_Input, + + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Result_Parameter, Loc), + Attribute_Name => Name_Access)))))); + + else + -- Loop around parameters and assign out (or in out) parameters. + -- In the case of RACW, controlling arguments cannot possibly + -- have changed since they are remote, so we do not read them + -- from the stream. + + Current_Parameter := + First (Ordered_Parameters_List); + + while Current_Parameter /= Empty loop + + if Out_Present (Current_Parameter) + and then + Etype (Parameter_Type (Current_Parameter)) /= Object_Type + then + Append_To (Non_Asynchronous_Statements, + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of ( + Etype (Parameter_Type (Current_Parameter)), Loc), + + Attribute_Name => Name_Read, + + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Result_Parameter, Loc), + Attribute_Name => + Name_Access), + New_Occurrence_Of ( + Defining_Identifier (Current_Parameter), Loc)))); + end if; + + Next (Current_Parameter); + end loop; + end if; + end if; + + if Is_Known_Asynchronous then + Append_List_To (Statements, Asynchronous_Statements); + + elsif Is_Known_Non_Asynchronous then + Append_List_To (Statements, Non_Asynchronous_Statements); + + else + pragma Assert (Asynchronous /= Empty); + Prepend_To (Asynchronous_Statements, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Standard_Boolean, Loc), + Attribute_Name => Name_Write, + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Stream_Parameter, Loc), + Attribute_Name => Name_Access), + New_Occurrence_Of (Standard_True, Loc)))); + Prepend_To (Non_Asynchronous_Statements, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Standard_Boolean, Loc), + Attribute_Name => Name_Write, + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Stream_Parameter, Loc), + Attribute_Name => Name_Access), + New_Occurrence_Of (Standard_False, Loc)))); + Append_To (Statements, + Make_Implicit_If_Statement (Nod, + Condition => Asynchronous, + Then_Statements => Asynchronous_Statements, + Else_Statements => Non_Asynchronous_Statements)); + end if; + end Build_General_Calling_Stubs; + + ----------------------------------- + -- Build_Ordered_Parameters_List -- + ----------------------------------- + + function Build_Ordered_Parameters_List (Spec : Node_Id) return List_Id is + Constrained_List : List_Id; + Unconstrained_List : List_Id; + Current_Parameter : Node_Id; + + begin + if not Present (Parameter_Specifications (Spec)) then + return New_List; + end if; + + Constrained_List := New_List; + Unconstrained_List := New_List; + + -- Loop through the parameters and add them to the right list + + Current_Parameter := First (Parameter_Specifications (Spec)); + while Current_Parameter /= Empty loop + + if Nkind (Parameter_Type (Current_Parameter)) = N_Access_Definition + or else + Is_Constrained (Etype (Parameter_Type (Current_Parameter))) + or else + Is_Elementary_Type (Etype (Parameter_Type (Current_Parameter))) + then + Append_To (Constrained_List, New_Copy (Current_Parameter)); + else + Append_To (Unconstrained_List, New_Copy (Current_Parameter)); + end if; + + Next (Current_Parameter); + end loop; + + -- Unconstrained parameters are returned first + + Append_List_To (Unconstrained_List, Constrained_List); + + return Unconstrained_List; + + end Build_Ordered_Parameters_List; + + ---------------------------------- + -- Build_Passive_Partition_Stub -- + ---------------------------------- + + procedure Build_Passive_Partition_Stub (U : Node_Id) is + Pkg_Spec : Node_Id; + L : List_Id; + Reg : Node_Id; + Loc : constant Source_Ptr := Sloc (U); + Dist_OK : Entity_Id; + + begin + -- Verify that the implementation supports distribution, by accessing + -- a type defined in the proper version of system.rpc + + Dist_OK := RTE (RE_Params_Stream_Type); + + -- Use body if present, spec otherwise + + if Nkind (U) = N_Package_Declaration then + Pkg_Spec := Specification (U); + L := Visible_Declarations (Pkg_Spec); + else + Pkg_Spec := Parent (Corresponding_Spec (U)); + L := Declarations (U); + end if; + + Reg := + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Register_Passive_Package), Loc), + Parameter_Associations => New_List ( + Make_String_Literal (Loc, Get_Pkg_Name_String_Id (Pkg_Spec)), + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc), + Attribute_Name => + Name_Version))); + Append_To (L, Reg); + Analyze (Reg); + end Build_Passive_Partition_Stub; + + ------------------------------------ + -- Build_Subprogram_Calling_Stubs -- + ------------------------------------ + + function Build_Subprogram_Calling_Stubs + (Vis_Decl : Node_Id; + Subp_Id : Int; + Asynchronous : Boolean; + Dynamically_Asynchronous : Boolean := False; + Stub_Type : Entity_Id := Empty; + Locator : Entity_Id := Empty; + New_Name : Name_Id := No_Name) + return Node_Id + is + Loc : constant Source_Ptr := Sloc (Vis_Decl); + + Target_Partition : Node_Id; + -- Contains the name of the target partition + + Decls : constant List_Id := New_List; + Statements : constant List_Id := New_List; + + Subp_Spec : Node_Id; + -- The specification of the body + + Controlling_Parameter : Entity_Id := Empty; + RPC_Receiver : Node_Id; + + Asynchronous_Expr : Node_Id := Empty; + + RCI_Locator : Entity_Id; + + Spec_To_Use : Node_Id; + + procedure Insert_Partition_Check (Parameter : in Node_Id); + -- Check that the parameter has been elaborated on the same partition + -- than the controlling parameter (E.4(19)). + + ---------------------------- + -- Insert_Partition_Check -- + ---------------------------- + + procedure Insert_Partition_Check (Parameter : in Node_Id) is + Parameter_Entity : constant Entity_Id := + Defining_Identifier (Parameter); + Designated_Object : Node_Id; + Condition : Node_Id; + + begin + -- The expression that will be built is of the form: + -- if not (Parameter in Stub_Type and then + -- Parameter.Origin = Controlling.Origin) + -- then + -- raise Constraint_Error; + -- end if; + -- + -- Condition contains the reversed condition. Also, Parameter is + -- dereferenced if it is an access type. We do not check that + -- Parameter is in Stub_Type since such a check has been inserted + -- at the point of call already (a tag check since we have multiple + -- controlling operands). + + if Nkind (Parameter_Type (Parameter)) = N_Access_Definition then + Designated_Object := + Make_Explicit_Dereference (Loc, + Prefix => New_Occurrence_Of (Parameter_Entity, Loc)); + else + Designated_Object := New_Occurrence_Of (Parameter_Entity, Loc); + end if; + + Condition := + Make_Op_Eq (Loc, + Left_Opnd => + Make_Selected_Component (Loc, + Prefix => + New_Occurrence_Of (Parameter_Entity, Loc), + Selector_Name => + Make_Identifier (Loc, Name_Origin)), + + Right_Opnd => + Make_Selected_Component (Loc, + Prefix => + New_Occurrence_Of (Controlling_Parameter, Loc), + Selector_Name => + Make_Identifier (Loc, Name_Origin))); + + Append_To (Decls, + Make_Raise_Constraint_Error (Loc, + Condition => + Make_Op_Not (Loc, Right_Opnd => Condition))); + end Insert_Partition_Check; + + -- Start of processing for Build_Subprogram_Calling_Stubs + + begin + Target_Partition := + Make_Defining_Identifier (Loc, New_Internal_Name ('P')); + + Subp_Spec := Copy_Specification (Loc, + Spec => Specification (Vis_Decl), + New_Name => New_Name); + + if Locator = Empty then + RCI_Locator := RCI_Cache; + Spec_To_Use := Specification (Vis_Decl); + else + RCI_Locator := Locator; + Spec_To_Use := Subp_Spec; + end if; + + -- Find a controlling argument if we have a stub type. Also check + -- if this subprogram can be made asynchronous. + + if Stub_Type /= Empty + and then Present (Parameter_Specifications (Spec_To_Use)) + then + declare + Current_Parameter : Node_Id := + First (Parameter_Specifications + (Spec_To_Use)); + begin + while Current_Parameter /= Empty loop + + if + Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type) + then + if Controlling_Parameter = Empty then + Controlling_Parameter := + Defining_Identifier (Current_Parameter); + else + Insert_Partition_Check (Current_Parameter); + end if; + end if; + + Next (Current_Parameter); + end loop; + end; + end if; + + if Stub_Type /= Empty then + pragma Assert (Controlling_Parameter /= Empty); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Target_Partition, + Constant_Present => True, + Object_Definition => + New_Occurrence_Of (RTE (RE_Partition_ID), Loc), + + Expression => + Make_Selected_Component (Loc, + Prefix => + New_Occurrence_Of (Controlling_Parameter, Loc), + Selector_Name => + Make_Identifier (Loc, Name_Origin)))); + + RPC_Receiver := + Make_Selected_Component (Loc, + Prefix => + New_Occurrence_Of (Controlling_Parameter, Loc), + Selector_Name => + Make_Identifier (Loc, Name_Receiver)); + + else + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Target_Partition, + Constant_Present => True, + Object_Definition => + New_Occurrence_Of (RTE (RE_Partition_ID), Loc), + + Expression => + Make_Function_Call (Loc, + Name => Make_Selected_Component (Loc, + Prefix => + Make_Identifier (Loc, Chars (RCI_Locator)), + Selector_Name => + Make_Identifier (Loc, Name_Get_Active_Partition_ID))))); + + RPC_Receiver := + Make_Selected_Component (Loc, + Prefix => + Make_Identifier (Loc, Chars (RCI_Locator)), + Selector_Name => + Make_Identifier (Loc, Name_Get_RCI_Package_Receiver)); + end if; + + if Dynamically_Asynchronous then + Asynchronous_Expr := + Make_Selected_Component (Loc, + Prefix => + New_Occurrence_Of (Controlling_Parameter, Loc), + Selector_Name => + Make_Identifier (Loc, Name_Asynchronous)); + end if; + + Build_General_Calling_Stubs + (Decls => Decls, + Statements => Statements, + Target_Partition => Target_Partition, + RPC_Receiver => RPC_Receiver, + Subprogram_Id => Make_Integer_Literal (Loc, Subp_Id), + Asynchronous => Asynchronous_Expr, + Is_Known_Asynchronous => Asynchronous + and then not Dynamically_Asynchronous, + Is_Known_Non_Asynchronous + => not Asynchronous + and then not Dynamically_Asynchronous, + Is_Function => Nkind (Spec_To_Use) = + N_Function_Specification, + Spec => Spec_To_Use, + Object_Type => Stub_Type, + Nod => Vis_Decl); + + RCI_Calling_Stubs_Table.Set + (Defining_Unit_Name (Specification (Vis_Decl)), + Defining_Unit_Name (Spec_To_Use)); + + return + Make_Subprogram_Body (Loc, + Specification => Subp_Spec, + Declarations => Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, Statements)); + end Build_Subprogram_Calling_Stubs; + + -------------------------------------- + -- Build_Subprogram_Receiving_Stubs -- + -------------------------------------- + + function Build_Subprogram_Receiving_Stubs + (Vis_Decl : Node_Id; + Asynchronous : Boolean; + Dynamically_Asynchronous : Boolean := False; + Stub_Type : Entity_Id := Empty; + RACW_Type : Entity_Id := Empty; + Parent_Primitive : Entity_Id := Empty) + return Node_Id + is + Loc : constant Source_Ptr := Sloc (Vis_Decl); + + Stream_Parameter : Node_Id; + Result_Parameter : Node_Id; + -- See explanations of those in Build_Subprogram_Calling_Stubs + + Decls : List_Id := New_List; + -- All the parameters will get declared before calling the real + -- subprograms. Also the out parameters will be declared. + + Statements : List_Id := New_List; + + Extra_Formal_Statements : List_Id := New_List; + -- Statements concerning extra formal parameters + + After_Statements : List_Id := New_List; + -- Statements to be executed after the subprogram call + + Inner_Decls : List_Id := No_List; + -- In case of a function, the inner declarations are needed since + -- the result may be unconstrained. + + Excep_Handler : Node_Id; + Excep_Choice : Entity_Id; + Excep_Code : List_Id; + + Parameter_List : List_Id := New_List; + -- List of parameters to be passed to the subprogram. + + Current_Parameter : Node_Id; + + Ordered_Parameters_List : constant List_Id := + Build_Ordered_Parameters_List (Specification (Vis_Decl)); + + Subp_Spec : Node_Id; + -- Subprogram specification + + Called_Subprogram : Node_Id; + -- The subprogram to call + + Null_Raise_Statement : Node_Id; + + Dynamic_Async : Entity_Id; + + begin + if RACW_Type /= Empty then + Called_Subprogram := + New_Occurrence_Of (Parent_Primitive, Loc); + else + Called_Subprogram := + New_Occurrence_Of ( + Defining_Unit_Name (Specification (Vis_Decl)), Loc); + end if; + + Stream_Parameter := + Make_Defining_Identifier (Loc, New_Internal_Name ('S')); + + if Dynamically_Asynchronous then + Dynamic_Async := + Make_Defining_Identifier (Loc, New_Internal_Name ('S')); + else + Dynamic_Async := Empty; + end if; + + if not Asynchronous or else Dynamically_Asynchronous then + Result_Parameter := + Make_Defining_Identifier (Loc, New_Internal_Name ('S')); + + -- The first statement after the subprogram call is a statement to + -- writes a Null_Occurrence into the result stream. + + Null_Raise_Statement := + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc), + Attribute_Name => Name_Write, + Expressions => New_List ( + New_Occurrence_Of (Result_Parameter, Loc), + New_Occurrence_Of (RTE (RE_Null_Occurrence), Loc))); + + if Dynamically_Asynchronous then + Null_Raise_Statement := + Make_Implicit_If_Statement (Vis_Decl, + Condition => + Make_Op_Not (Loc, New_Occurrence_Of (Dynamic_Async, Loc)), + Then_Statements => New_List (Null_Raise_Statement)); + end if; + + Append_To (After_Statements, Null_Raise_Statement); + + else + Result_Parameter := Empty; + end if; + + -- Loop through every parameter and get its value from the stream. If + -- the parameter is unconstrained, then the parameter is read using + -- 'Input at the point of declaration. + + Current_Parameter := First (Ordered_Parameters_List); + + while Current_Parameter /= Empty loop + + declare + Etyp : Entity_Id; + Constrained : Boolean; + Object : Entity_Id; + Expr : Node_Id := Empty; + + begin + Object := Make_Defining_Identifier (Loc, New_Internal_Name ('P')); + Set_Ekind (Object, E_Variable); + + if + Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type) + then + -- We have a controlling formal parameter. Read its address + -- rather than a real object. The address is in Unsigned_64 + -- form. + + Etyp := RTE (RE_Unsigned_64); + else + Etyp := Etype (Parameter_Type (Current_Parameter)); + end if; + + Constrained := + Is_Constrained (Etyp) or else Is_Elementary_Type (Etyp); + + if In_Present (Current_Parameter) + or else not Out_Present (Current_Parameter) + or else not Constrained + then + -- If an input parameter is contrained, then its reading is + -- deferred until the beginning of the subprogram body. If + -- it is unconstrained, then an expression is built for + -- the object declaration and the variable is set using + -- 'Input instead of 'Read. + + if Constrained then + Append_To (Statements, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Etyp, Loc), + Attribute_Name => Name_Read, + Expressions => New_List ( + New_Occurrence_Of (Stream_Parameter, Loc), + New_Occurrence_Of (Object, Loc)))); + + else + Expr := Input_With_Tag_Check (Loc, + Var_Type => Etyp, + Stream => Stream_Parameter); + Append_To (Decls, Expr); + Expr := Make_Function_Call (Loc, + New_Occurrence_Of (Defining_Unit_Name + (Specification (Expr)), Loc)); + end if; + end if; + + -- If we do not have to output the current parameter, then + -- it can well be flagged as constant. This may allow further + -- optimizations done by the back end. + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Object, + Constant_Present => + not Constrained and then not Out_Present (Current_Parameter), + Object_Definition => + New_Occurrence_Of (Etyp, Loc), + Expression => Expr)); + + -- An out parameter may be written back using a 'Write + -- attribute instead of a 'Output because it has been + -- constrained by the parameter given to the caller. Note that + -- out controlling arguments in the case of a RACW are not put + -- back in the stream because the pointer on them has not + -- changed. + + if Out_Present (Current_Parameter) + and then + Etype (Parameter_Type (Current_Parameter)) /= Stub_Type + then + Append_To (After_Statements, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Etyp, Loc), + Attribute_Name => Name_Write, + Expressions => New_List ( + New_Occurrence_Of (Result_Parameter, Loc), + New_Occurrence_Of (Object, Loc)))); + end if; + + if + Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type) + then + + if Nkind (Parameter_Type (Current_Parameter)) /= + N_Access_Definition + then + Append_To (Parameter_List, + Make_Parameter_Association (Loc, + Selector_Name => + New_Occurrence_Of ( + Defining_Identifier (Current_Parameter), Loc), + Explicit_Actual_Parameter => + Make_Explicit_Dereference (Loc, + Unchecked_Convert_To (RACW_Type, + OK_Convert_To (RTE (RE_Address), + New_Occurrence_Of (Object, Loc)))))); + else + Append_To (Parameter_List, + Make_Parameter_Association (Loc, + Selector_Name => + New_Occurrence_Of ( + Defining_Identifier (Current_Parameter), Loc), + Explicit_Actual_Parameter => + Unchecked_Convert_To (RACW_Type, + OK_Convert_To (RTE (RE_Address), + New_Occurrence_Of (Object, Loc))))); + end if; + else + Append_To (Parameter_List, + Make_Parameter_Association (Loc, + Selector_Name => + New_Occurrence_Of ( + Defining_Identifier (Current_Parameter), Loc), + Explicit_Actual_Parameter => + New_Occurrence_Of (Object, Loc))); + end if; + + -- If the current parameter needs an extra formal, then read it + -- from the stream and set the corresponding semantic field in + -- the variable. If the kind of the parameter identifier is + -- E_Void, then this is a compiler generated parameter that + -- doesn't need an extra constrained status. + + -- The case of Extra_Accessibility should also be handled ??? + + if Nkind (Parameter_Type (Current_Parameter)) /= + N_Access_Definition + and then + Ekind (Defining_Identifier (Current_Parameter)) /= E_Void + and then + Present (Extra_Constrained + (Defining_Identifier (Current_Parameter))) + then + declare + Extra_Parameter : constant Entity_Id := + Extra_Constrained + (Defining_Identifier + (Current_Parameter)); + + Formal_Entity : constant Entity_Id := + Make_Defining_Identifier + (Loc, Chars (Extra_Parameter)); + + Formal_Type : constant Entity_Id := + Etype (Extra_Parameter); + + begin + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Formal_Entity, + Object_Definition => + New_Occurrence_Of (Formal_Type, Loc))); + + Append_To (Extra_Formal_Statements, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Formal_Type, Loc), + Attribute_Name => Name_Read, + Expressions => New_List ( + New_Occurrence_Of (Stream_Parameter, Loc), + New_Occurrence_Of (Formal_Entity, Loc)))); + Set_Extra_Constrained (Object, Formal_Entity); + end; + end if; + end; + + Next (Current_Parameter); + end loop; + + -- Append the formal statements list at the end of regular statements + + Append_List_To (Statements, Extra_Formal_Statements); + + if Nkind (Specification (Vis_Decl)) = N_Function_Specification then + + -- The remote subprogram is a function. We build an inner block to + -- be able to hold a potentially unconstrained result in a variable. + + declare + Etyp : constant Entity_Id := + Etype (Subtype_Mark (Specification (Vis_Decl))); + Result : constant Node_Id := + Make_Defining_Identifier (Loc, New_Internal_Name ('R')); + + begin + Inner_Decls := New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => Result, + Constant_Present => True, + Object_Definition => New_Occurrence_Of (Etyp, Loc), + Expression => + Make_Function_Call (Loc, + Name => Called_Subprogram, + Parameter_Associations => Parameter_List))); + + Append_To (After_Statements, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Etyp, Loc), + Attribute_Name => Name_Output, + Expressions => New_List ( + New_Occurrence_Of (Result_Parameter, Loc), + New_Occurrence_Of (Result, Loc)))); + end; + + Append_To (Statements, + Make_Block_Statement (Loc, + Declarations => Inner_Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => After_Statements))); + + else + -- The remote subprogram is a procedure. We do not need any inner + -- block in this case. + + if Dynamically_Asynchronous then + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Dynamic_Async, + Object_Definition => + New_Occurrence_Of (Standard_Boolean, Loc))); + + Append_To (Statements, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Standard_Boolean, Loc), + Attribute_Name => Name_Read, + Expressions => New_List ( + New_Occurrence_Of (Stream_Parameter, Loc), + New_Occurrence_Of (Dynamic_Async, Loc)))); + end if; + + Append_To (Statements, + Make_Procedure_Call_Statement (Loc, + Name => Called_Subprogram, + Parameter_Associations => Parameter_List)); + + Append_List_To (Statements, After_Statements); + + end if; + + if Asynchronous and then not Dynamically_Asynchronous then + + -- An asynchronous procedure does not want a Result + -- parameter. Also, we put an exception handler with an others + -- clause that does nothing. + + Subp_Spec := + Make_Procedure_Specification (Loc, + Defining_Unit_Name => + Make_Defining_Identifier (Loc, New_Internal_Name ('F')), + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Stream_Parameter, + Parameter_Type => + Make_Access_Definition (Loc, + Subtype_Mark => + New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc))))); + + Excep_Handler := + Make_Exception_Handler (Loc, + Exception_Choices => + New_List (Make_Others_Choice (Loc)), + Statements => New_List ( + Make_Null_Statement (Loc))); + + else + -- In the other cases, if an exception is raised, then the + -- exception occurrence is copied into the output stream and + -- no other output parameter is written. + + Excep_Choice := + Make_Defining_Identifier (Loc, New_Internal_Name ('E')); + + Excep_Code := New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc), + Attribute_Name => Name_Write, + Expressions => New_List ( + New_Occurrence_Of (Result_Parameter, Loc), + New_Occurrence_Of (Excep_Choice, Loc)))); + + if Dynamically_Asynchronous then + Excep_Code := New_List ( + Make_Implicit_If_Statement (Vis_Decl, + Condition => Make_Op_Not (Loc, + New_Occurrence_Of (Dynamic_Async, Loc)), + Then_Statements => Excep_Code)); + end if; + + Excep_Handler := + Make_Exception_Handler (Loc, + Choice_Parameter => Excep_Choice, + Exception_Choices => New_List (Make_Others_Choice (Loc)), + Statements => Excep_Code); + + Subp_Spec := + Make_Procedure_Specification (Loc, + Defining_Unit_Name => + Make_Defining_Identifier (Loc, New_Internal_Name ('F')), + + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Stream_Parameter, + Parameter_Type => + Make_Access_Definition (Loc, + Subtype_Mark => + New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc))), + + Make_Parameter_Specification (Loc, + Defining_Identifier => Result_Parameter, + Parameter_Type => + Make_Access_Definition (Loc, + Subtype_Mark => + New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc))))); + end if; + + return + Make_Subprogram_Body (Loc, + Specification => Subp_Spec, + Declarations => Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Statements, + Exception_Handlers => New_List (Excep_Handler))); + + end Build_Subprogram_Receiving_Stubs; + + ------------------------ + -- Copy_Specification -- + ------------------------ + + function Copy_Specification + (Loc : Source_Ptr; + Spec : Node_Id; + Object_Type : Entity_Id := Empty; + Stub_Type : Entity_Id := Empty; + New_Name : Name_Id := No_Name) + return Node_Id + is + Parameters : List_Id := No_List; + + Current_Parameter : Node_Id; + Current_Type : Node_Id; + + Name_For_New_Spec : Name_Id; + + New_Identifier : Entity_Id; + + begin + if New_Name = No_Name then + Name_For_New_Spec := Chars (Defining_Unit_Name (Spec)); + else + Name_For_New_Spec := New_Name; + end if; + + if Present (Parameter_Specifications (Spec)) then + + Parameters := New_List; + Current_Parameter := First (Parameter_Specifications (Spec)); + + while Current_Parameter /= Empty loop + + Current_Type := Parameter_Type (Current_Parameter); + + if Nkind (Current_Type) = N_Access_Definition then + if Object_Type = Empty then + Current_Type := + Make_Access_Definition (Loc, + Subtype_Mark => + New_Occurrence_Of (Etype ( + Subtype_Mark (Current_Type)), Loc)); + else + pragma Assert + (Root_Type (Etype (Subtype_Mark (Current_Type))) + = Root_Type (Object_Type)); + Current_Type := + Make_Access_Definition (Loc, + Subtype_Mark => New_Occurrence_Of (Stub_Type, Loc)); + end if; + + elsif Object_Type /= Empty + and then Etype (Current_Type) = Object_Type + then + Current_Type := New_Occurrence_Of (Stub_Type, Loc); + + else + Current_Type := New_Occurrence_Of (Etype (Current_Type), Loc); + end if; + + New_Identifier := Make_Defining_Identifier (Loc, + Chars (Defining_Identifier (Current_Parameter))); + + Append_To (Parameters, + Make_Parameter_Specification (Loc, + Defining_Identifier => New_Identifier, + Parameter_Type => Current_Type, + In_Present => In_Present (Current_Parameter), + Out_Present => Out_Present (Current_Parameter), + Expression => + New_Copy_Tree (Expression (Current_Parameter)))); + + Next (Current_Parameter); + end loop; + end if; + + if Nkind (Spec) = N_Function_Specification then + return + Make_Function_Specification (Loc, + Defining_Unit_Name => + Make_Defining_Identifier (Loc, + Chars => Name_For_New_Spec), + Parameter_Specifications => Parameters, + Subtype_Mark => + New_Occurrence_Of (Etype (Subtype_Mark (Spec)), Loc)); + + else + return + Make_Procedure_Specification (Loc, + Defining_Unit_Name => + Make_Defining_Identifier (Loc, + Chars => Name_For_New_Spec), + Parameter_Specifications => Parameters); + end if; + + end Copy_Specification; + + --------------------------- + -- Could_Be_Asynchronous -- + --------------------------- + + function Could_Be_Asynchronous (Spec : Node_Id) return Boolean is + Current_Parameter : Node_Id; + + begin + if Present (Parameter_Specifications (Spec)) then + Current_Parameter := First (Parameter_Specifications (Spec)); + while Current_Parameter /= Empty loop + if Out_Present (Current_Parameter) then + return False; + end if; + + Next (Current_Parameter); + end loop; + end if; + + return True; + end Could_Be_Asynchronous; + + --------------------------------------------- + -- Expand_All_Calls_Remote_Subprogram_Call -- + --------------------------------------------- + + procedure Expand_All_Calls_Remote_Subprogram_Call (N : in Node_Id) is + Called_Subprogram : constant Entity_Id := Entity (Name (N)); + RCI_Package : constant Entity_Id := Scope (Called_Subprogram); + Loc : constant Source_Ptr := Sloc (N); + RCI_Locator : Node_Id; + RCI_Cache : Entity_Id; + Calling_Stubs : Node_Id; + E_Calling_Stubs : Entity_Id; + + begin + E_Calling_Stubs := RCI_Calling_Stubs_Table.Get (Called_Subprogram); + + if E_Calling_Stubs = Empty then + RCI_Cache := RCI_Locator_Table.Get (RCI_Package); + + if RCI_Cache = Empty then + RCI_Locator := + RCI_Package_Locator + (Loc, Specification (Unit_Declaration_Node (RCI_Package))); + Prepend_To (Current_Sem_Unit_Declarations, RCI_Locator); + + -- The RCI_Locator package is inserted at the top level in the + -- current unit, and must appear in the proper scope, so that it + -- is not prematurely removed by the GCC back-end. + + declare + Scop : Entity_Id := Cunit_Entity (Current_Sem_Unit); + + begin + if Ekind (Scop) = E_Package_Body then + New_Scope (Spec_Entity (Scop)); + + elsif Ekind (Scop) = E_Subprogram_Body then + New_Scope + (Corresponding_Spec (Unit_Declaration_Node (Scop))); + + else + New_Scope (Scop); + end if; + + Analyze (RCI_Locator); + Pop_Scope; + end; + + RCI_Cache := Defining_Unit_Name (RCI_Locator); + + else + RCI_Locator := Parent (RCI_Cache); + end if; + + Calling_Stubs := Build_Subprogram_Calling_Stubs + (Vis_Decl => Parent (Parent (Called_Subprogram)), + Subp_Id => Get_Subprogram_Id (Called_Subprogram), + Asynchronous => Nkind (N) = N_Procedure_Call_Statement + and then + Is_Asynchronous (Called_Subprogram), + Locator => RCI_Cache, + New_Name => New_Internal_Name ('S')); + Insert_After (RCI_Locator, Calling_Stubs); + Analyze (Calling_Stubs); + E_Calling_Stubs := Defining_Unit_Name (Specification (Calling_Stubs)); + end if; + + Rewrite (Name (N), New_Occurrence_Of (E_Calling_Stubs, Loc)); + end Expand_All_Calls_Remote_Subprogram_Call; + + --------------------------------- + -- Expand_Calling_Stubs_Bodies -- + --------------------------------- + + procedure Expand_Calling_Stubs_Bodies (Unit_Node : in Node_Id) is + Spec : constant Node_Id := Specification (Unit_Node); + Decls : constant List_Id := Visible_Declarations (Spec); + + begin + New_Scope (Scope_Of_Spec (Spec)); + Add_Calling_Stubs_To_Declarations (Specification (Unit_Node), + Decls); + Pop_Scope; + end Expand_Calling_Stubs_Bodies; + + ----------------------------------- + -- Expand_Receiving_Stubs_Bodies -- + ----------------------------------- + + procedure Expand_Receiving_Stubs_Bodies (Unit_Node : in Node_Id) is + Spec : Node_Id; + Decls : List_Id; + Temp : List_Id; + + begin + if Nkind (Unit_Node) = N_Package_Declaration then + Spec := Specification (Unit_Node); + Decls := Visible_Declarations (Spec); + New_Scope (Scope_Of_Spec (Spec)); + Add_Receiving_Stubs_To_Declarations (Spec, Decls); + + else + Spec := + Package_Specification_Of_Scope (Corresponding_Spec (Unit_Node)); + Decls := Declarations (Unit_Node); + New_Scope (Scope_Of_Spec (Unit_Node)); + Temp := New_List; + Add_Receiving_Stubs_To_Declarations (Spec, Temp); + Insert_List_Before (First (Decls), Temp); + end if; + + Pop_Scope; + end Expand_Receiving_Stubs_Bodies; + + ---------------------------- + -- Get_Pkg_Name_string_Id -- + ---------------------------- + + function Get_Pkg_Name_String_Id (Decl_Node : Node_Id) return String_Id is + Unit_Name_Id : Unit_Name_Type := Get_Unit_Name (Decl_Node); + + begin + Get_Unit_Name_String (Unit_Name_Id); + + -- Remove seven last character (" (spec)" or " (body)"). + + Name_Len := Name_Len - 7; + pragma Assert (Name_Buffer (Name_Len + 1) = ' '); + + return Get_String_Id (Name_Buffer (1 .. Name_Len)); + end Get_Pkg_Name_String_Id; + + ------------------- + -- Get_String_Id -- + ------------------- + + function Get_String_Id (Val : String) return String_Id is + begin + Start_String; + Store_String_Chars (Val); + return End_String; + end Get_String_Id; + + ---------- + -- Hash -- + ---------- + + function Hash (F : Entity_Id) return Hash_Index is + begin + return Hash_Index (Natural (F) mod Positive (Hash_Index'Last + 1)); + end Hash; + + -------------------------- + -- Input_With_Tag_Check -- + -------------------------- + + function Input_With_Tag_Check + (Loc : Source_Ptr; + Var_Type : Entity_Id; + Stream : Entity_Id) + return Node_Id + is + begin + return + Make_Subprogram_Body (Loc, + Specification => Make_Function_Specification (Loc, + Defining_Unit_Name => + Make_Defining_Identifier (Loc, New_Internal_Name ('S')), + Subtype_Mark => New_Occurrence_Of (Var_Type, Loc)), + Declarations => No_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, New_List ( + Make_Tag_Check (Loc, + Make_Return_Statement (Loc, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Var_Type, Loc), + Attribute_Name => Name_Input, + Expressions => + New_List (New_Occurrence_Of (Stream, Loc)))))))); + end Input_With_Tag_Check; + + -------------------------------- + -- Is_RACW_Controlling_Formal -- + -------------------------------- + + function Is_RACW_Controlling_Formal + (Parameter : Node_Id; + Stub_Type : Entity_Id) + return Boolean + is + Typ : Entity_Id; + + begin + -- If the kind of the parameter is E_Void, then it is not a + -- controlling formal (this can happen in the context of RAS). + + if Ekind (Defining_Identifier (Parameter)) = E_Void then + return False; + end if; + + -- If the parameter is not a controlling formal, then it cannot + -- be possibly a RACW_Controlling_Formal. + + if not Is_Controlling_Formal (Defining_Identifier (Parameter)) then + return False; + end if; + + Typ := Parameter_Type (Parameter); + return (Nkind (Typ) = N_Access_Definition + and then Etype (Subtype_Mark (Typ)) = Stub_Type) + or else Etype (Typ) = Stub_Type; + end Is_RACW_Controlling_Formal; + + -------------------- + -- Make_Tag_Check -- + -------------------- + + function Make_Tag_Check (Loc : Source_Ptr; N : Node_Id) return Node_Id is + Occ : constant Entity_Id := + Make_Defining_Identifier (Loc, New_Internal_Name ('E')); + + begin + return Make_Block_Statement (Loc, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (N), + + Exception_Handlers => New_List ( + Make_Exception_Handler (Loc, + Choice_Parameter => Occ, + + Exception_Choices => + New_List (New_Occurrence_Of (RTE (RE_Tag_Error), Loc)), + + Statements => + New_List (Make_Procedure_Call_Statement (Loc, + New_Occurrence_Of + (RTE (RE_Raise_Program_Error_Unknown_Tag), Loc), + New_List (New_Occurrence_Of (Occ, Loc)))))))); + end Make_Tag_Check; + + ---------------------------- + -- Need_Extra_Constrained -- + ---------------------------- + + function Need_Extra_Constrained (Parameter : Node_Id) return Boolean is + Etyp : constant Entity_Id := Etype (Parameter_Type (Parameter)); + + begin + return Out_Present (Parameter) + and then Has_Discriminants (Etyp) + and then not Is_Constrained (Etyp) + and then not Is_Indefinite_Subtype (Etyp); + end Need_Extra_Constrained; + + ------------------------------------ + -- Pack_Entity_Into_Stream_Access -- + ------------------------------------ + + function Pack_Entity_Into_Stream_Access + (Loc : Source_Ptr; + Stream : Entity_Id; + Object : Entity_Id; + Etyp : Entity_Id := Empty) + return Node_Id + is + Typ : Entity_Id; + + begin + if Etyp /= Empty then + Typ := Etyp; + else + Typ := Etype (Object); + end if; + + return + Pack_Node_Into_Stream_Access (Loc, + Stream => Stream, + Object => New_Occurrence_Of (Object, Loc), + Etyp => Typ); + end Pack_Entity_Into_Stream_Access; + + --------------------------- + -- Pack_Node_Into_Stream -- + --------------------------- + + function Pack_Node_Into_Stream + (Loc : Source_Ptr; + Stream : Entity_Id; + Object : Node_Id; + Etyp : Entity_Id) + return Node_Id + is + Write_Attribute : Name_Id := Name_Write; + + begin + if not Is_Constrained (Etyp) then + Write_Attribute := Name_Output; + end if; + + return + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Etyp, Loc), + Attribute_Name => Write_Attribute, + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Stream, Loc), + Attribute_Name => Name_Access), + Object)); + end Pack_Node_Into_Stream; + + ---------------------------------- + -- Pack_Node_Into_Stream_Access -- + ---------------------------------- + + function Pack_Node_Into_Stream_Access + (Loc : Source_Ptr; + Stream : Entity_Id; + Object : Node_Id; + Etyp : Entity_Id) + return Node_Id + is + Write_Attribute : Name_Id := Name_Write; + + begin + if not Is_Constrained (Etyp) then + Write_Attribute := Name_Output; + end if; + + return + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Etyp, Loc), + Attribute_Name => Write_Attribute, + Expressions => New_List ( + New_Occurrence_Of (Stream, Loc), + Object)); + end Pack_Node_Into_Stream_Access; + + ------------------------------- + -- RACW_Type_Is_Asynchronous -- + ------------------------------- + + procedure RACW_Type_Is_Asynchronous (RACW_Type : in Entity_Id) is + N : constant Node_Id := Asynchronous_Flags_Table.Get (RACW_Type); + pragma Assert (N /= Empty); + + begin + Replace (N, New_Occurrence_Of (Standard_True, Sloc (N))); + end RACW_Type_Is_Asynchronous; + + ------------------------- + -- RCI_Package_Locator -- + ------------------------- + + function RCI_Package_Locator + (Loc : Source_Ptr; + Package_Spec : Node_Id) + return Node_Id + is + Inst : constant Node_Id := + Make_Package_Instantiation (Loc, + Defining_Unit_Name => + Make_Defining_Identifier (Loc, New_Internal_Name ('R')), + Name => + New_Occurrence_Of (RTE (RE_RCI_Info), Loc), + Generic_Associations => New_List ( + Make_Generic_Association (Loc, + Selector_Name => + Make_Identifier (Loc, Name_RCI_Name), + Explicit_Generic_Actual_Parameter => + Make_String_Literal (Loc, + Strval => Get_Pkg_Name_String_Id (Package_Spec))))); + + begin + RCI_Locator_Table.Set (Defining_Unit_Name (Package_Spec), + Defining_Unit_Name (Inst)); + return Inst; + end RCI_Package_Locator; + + ----------------------------------------------- + -- Remote_Types_Tagged_Full_View_Encountered -- + ----------------------------------------------- + + procedure Remote_Types_Tagged_Full_View_Encountered + (Full_View : in Entity_Id) + is + Stub_Elements : constant Stub_Structure := + Stubs_Table.Get (Full_View); + + begin + if Stub_Elements /= Empty_Stub_Structure then + Add_RACW_Primitive_Declarations_And_Bodies + (Full_View, + Parent (Declaration_Node (Stub_Elements.Object_RPC_Receiver)), + List_Containing (Declaration_Node (Full_View))); + end if; + end Remote_Types_Tagged_Full_View_Encountered; + + ------------------- + -- Scope_Of_Spec -- + ------------------- + + function Scope_Of_Spec (Spec : Node_Id) return Entity_Id is + Unit_Name : Node_Id := Defining_Unit_Name (Spec); + + begin + while Nkind (Unit_Name) /= N_Defining_Identifier loop + Unit_Name := Defining_Identifier (Unit_Name); + end loop; + + return Unit_Name; + end Scope_Of_Spec; + +end Exp_Dist; |