------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- E X P_ D I S T -- -- -- -- B o d y -- -- -- -- -- -- Copyright (C) 1992-2002 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 record; -- 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), Reason => CE_Partition_Check_Failed)); 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;