X-Git-Url: https://oss.titaniummirror.com/gitweb/?a=blobdiff_plain;f=gcc%2Fada%2Fexp_dist.adb;fp=gcc%2Fada%2Fexp_dist.adb;h=0000000000000000000000000000000000000000;hb=6fed43773c9b0ce596dca5686f37ac3fc0fa11c0;hp=23e74c992f03c918e4744768e69a4286c075c93d;hpb=27b11d56b743098deb193d510b337ba22dc52e5c;p=msp430-gcc.git diff --git a/gcc/ada/exp_dist.adb b/gcc/ada/exp_dist.adb deleted file mode 100644 index 23e74c99..00000000 --- a/gcc/ada/exp_dist.adb +++ /dev/null @@ -1,3760 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- E X P_ D I S T -- --- -- --- B o d y -- --- -- --- $Revision: 1.1.16.1 $ --- -- --- 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. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -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 - -- ; - -- 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;