OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

exp_dist.ads, [...] (Make_Transportable_Check): New subprogram (GARLIC_Support.Build_Subprogram_Receiving_Stubs...

Browse Source 
2007-04-20  Thomas Quinot  <quinot@adacore.com>

	* exp_dist.ads, exp_dist.adb (Make_Transportable_Check): New subprogram
	(GARLIC_Support.Build_Subprogram_Receiving_Stubs,
	PolyORB_Support.Build_Subprogram_Receiving_Stubs):
	For a remote call to a function with a classwide return type, apply an
	E.4(18) check to the returned value.
	(Add_RACW_Primitive_Declarations_And_Bodies): Do not generate stubs for
	stream attributes of the designated type of an RACW, as they are not
	dispatching primitive operations.

From-SVN: r125403
This commit is contained in:
Thomas Quinot 2007-06-06 12:26:39 +02:00 committed by Arnaud Charlet
parent 7853d93425
commit c3d593c9d3
2 changed files with 240 additions and 112 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

341
gcc/ada/exp_dist.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2007, 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- --
@ -27,11 +27,11 @@
with Atree; use Atree;
with Einfo; use Einfo;
with Elists; use Elists;
with Exp_Atag; use Exp_Atag;
with Exp_Strm; use Exp_Strm;
with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
with Lib; use Lib;
with Namet; use Namet;
with Nlists; use Nlists;
with Nmake; use Nmake;
with Opt; use Opt;
@ -162,12 +162,12 @@ package body Exp_Dist is
Vis_Decl : Node_Id;
All_Calls_Remote_E : Entity_Id;
Proxy_Object_Addr : out Entity_Id);
-- Add the proxy type necessary to call the subprogram declared
-- by Vis_Decl through a remote access to subprogram type.
-- All_Calls_Remote_E must be Standard_True if a pragma All_Calls_Remote
-- applies, Standard_False otherwise. The new proxy type is appended
-- to Decls. Proxy_Object_Addr is a constant of type System.Address that
-- designates an instance of the proxy object.
-- Add the proxy type required, on the receiving (server) side, to handle
-- calls to the subprogram declared by Vis_Decl through a remote access
-- to subprogram type. All_Calls_Remote_E must be Standard_True if a pragma
-- All_Calls_Remote applies, Standard_False otherwise. The new proxy type
-- is appended to Decls. Proxy_Object_Addr is a constant of type
-- System.Address that designates an instance of the proxy object.
function Build_Remote_Subprogram_Proxy_Type
(Loc : Source_Ptr;
@ -1270,7 +1270,12 @@ package body Exp_Dist is
if Chars (Current_Primitive) /= Name_uSize
and then Chars (Current_Primitive) /= Name_uAlignment
and then not Is_TSS (Current_Primitive, TSS_Deep_Finalize)
and then not
(Is_TSS (Current_Primitive, TSS_Deep_Finalize) or else
Is_TSS (Current_Primitive, TSS_Stream_Input) or else
Is_TSS (Current_Primitive, TSS_Stream_Output) or else
Is_TSS (Current_Primitive, TSS_Stream_Read) or else
Is_TSS (Current_Primitive, TSS_Stream_Write))
then
-- The first thing to do is build an up-to-date copy of the
-- spec with all the formals referencing Designated_Type
@ -2705,14 +2710,14 @@ package body Exp_Dist is
begin
if Ekind (Scop) = E_Package_Body then
New_Scope (Spec_Entity (Scop));
Push_Scope (Spec_Entity (Scop));
elsif Ekind (Scop) = E_Subprogram_Body then
New_Scope
Push_Scope
(Corresponding_Spec (Unit_Declaration_Node (Scop)));
else
New_Scope (Scop);
Push_Scope (Scop);
end if;
Analyze (RCI_Locator);
@ -2750,7 +2755,7 @@ package body Exp_Dist is
Spec : constant Node_Id := Specification (Unit_Node);
Decls : constant List_Id := Visible_Declarations (Spec);
begin
New_Scope (Scope_Of_Spec (Spec));
Push_Scope (Scope_Of_Spec (Spec));
Add_Calling_Stubs_To_Declarations
(Specification (Unit_Node), Decls);
Pop_Scope;
@ -2774,7 +2779,7 @@ package body Exp_Dist is
Decls := Visible_Declarations (Spec);
end if;
New_Scope (Scope_Of_Spec (Spec));
Push_Scope (Scope_Of_Spec (Spec));
Specific_Add_Receiving_Stubs_To_Declarations
(Spec, Decls, Decls);
else
@ -2782,7 +2787,7 @@ package body Exp_Dist is
Package_Specification_Of_Scope (Corresponding_Spec (Unit_Node));
Decls := Declarations (Unit_Node);
New_Scope (Scope_Of_Spec (Unit_Node));
Push_Scope (Scope_Of_Spec (Unit_Node));
Temp := New_List;
Specific_Add_Receiving_Stubs_To_Declarations
(Spec, Temp, Statements (Handled_Statement_Sequence (Unit_Node)));
@ -3645,17 +3650,17 @@ package body Exp_Dist is
-- - 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
-- and will dispatch the call to the right subprogram;
-- - a receiving stub for any subprogram visible in the package
-- - a receiving stub for each subprogram visible in the package
-- spec. This stub will read all the parameters from the stream,
-- and put the result as well as the exception occurrence in the
-- output stream
-- 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
-- by calling System.Partition_Interface.Register_Receiving_Stub.
Build_RPC_Receiver_Body (
RPC_Receiver => Pkg_RPC_Receiver,
@ -3861,76 +3866,121 @@ package body Exp_Dist is
High_Bound =>
Make_Integer_Literal (Loc,
First_RCI_Subprogram_Id
+ List_Length (Subp_Info_List) - 1))))),
Expression =>
Make_Aggregate (Loc,
Component_Associations => Subp_Info_List)));
+ List_Length (Subp_Info_List) - 1)))))));
-- For a degenerate RCI with no visible subprograms, Subp_Info_List
-- has zero length, and the declaration is for an empty array, in
-- which case no initialization aggregate must be generated.
if Present (First (Subp_Info_List)) then
Set_Expression (Last (Decls),
Make_Aggregate (Loc,
Component_Associations => Subp_Info_List));
-- No initialization provided: remove CONSTANT so that the
-- declaration is not an incomplete deferred constant.
else
Set_Constant_Present (Last (Decls), False);
end if;
Analyze (Last (Decls));
Append_To (Decls,
Make_Subprogram_Body (Loc,
Specification =>
Copy_Specification (Loc, Parent (Lookup_RAS_Info)),
Declarations =>
No_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (
Make_Return_Statement (Loc,
Expression => OK_Convert_To (RTE (RE_Unsigned_64),
Make_Selected_Component (Loc,
Prefix =>
Make_Indexed_Component (Loc,
Prefix =>
New_Occurrence_Of (Subp_Info_Array, Loc),
Expressions => New_List (
Convert_To (Standard_Integer,
Make_Identifier (Loc, Name_Subp_Id)))),
Selector_Name =>
Make_Identifier (Loc, Name_Addr))))))));
declare
Subp_Info_Addr : Node_Id;
-- Return statement for Lookup_RAS_Info: address of the subprogram
-- information record for the requested subprogram id.
begin
if Present (First (Subp_Info_List)) then
Subp_Info_Addr :=
Make_Selected_Component (Loc,
Prefix =>
Make_Indexed_Component (Loc,
Prefix =>
New_Occurrence_Of (Subp_Info_Array, Loc),
Expressions => New_List (
Convert_To (Standard_Integer,
Make_Identifier (Loc, Name_Subp_Id)))),
Selector_Name =>
Make_Identifier (Loc, Name_Addr));
-- Case of no visible subprogram: just raise Constraint_Error, we
-- know for sure we got junk from a remote partition.
else
Subp_Info_Addr :=
Make_Raise_Constraint_Error (Loc,
Reason => CE_Range_Check_Failed);
Set_Etype (Subp_Info_Addr, RTE (RE_Unsigned_64));
end if;
Append_To (Decls,
Make_Subprogram_Body (Loc,
Specification =>
Copy_Specification (Loc, Parent (Lookup_RAS_Info)),
Declarations =>
No_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (
Make_Return_Statement (Loc,
Expression =>
OK_Convert_To (RTE (RE_Unsigned_64),
Subp_Info_Addr))))));
end;
Analyze (Last (Decls));
Append_To (Decls, Pkg_RPC_Receiver_Body);
Analyze (Last (Decls));
Get_Library_Unit_Name_String (Pkg_Spec);
-- Name
Append_To (Register_Pkg_Actuals,
-- Name
Make_String_Literal (Loc,
Strval => String_From_Name_Buffer));
-- Receiver
Append_To (Register_Pkg_Actuals,
-- Receiver
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Pkg_RPC_Receiver, Loc),
Attribute_Name =>
Name_Unrestricted_Access));
-- Version
Append_To (Register_Pkg_Actuals,
-- Version
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc),
Attribute_Name =>
Name_Version));
-- Subp_Info
Append_To (Register_Pkg_Actuals,
-- Subp_Info
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Subp_Info_Array, Loc),
Attribute_Name =>
Name_Address));
-- Subp_Info_Len
Append_To (Register_Pkg_Actuals,
-- Subp_Info_Len
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Subp_Info_Array, Loc),
Attribute_Name =>
Name_Length));
-- Generate the call
Append_To (Stmts,
Make_Procedure_Call_Statement (Loc,
Name =>
@ -4932,6 +4982,18 @@ package body Exp_Dist is
Name => Called_Subprogram,
Parameter_Associations => Parameter_List)));
if Is_Class_Wide_Type (Etyp) then
-- For a remote call to a function with a class-wide type,
-- check that the returned value satisfies the requirements
-- of E.4(18).
Append_To (Inner_Decls,
Make_Transportable_Check (Loc,
New_Occurrence_Of (Result, Loc)));
end if;
Append_To (After_Statements,
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Etyp, Loc),
@ -5195,6 +5257,25 @@ package body Exp_Dist is
or else Etype (Typ) = Stub_Type;
end Is_RACW_Controlling_Formal;
------------------------------
-- Make_Transportable_Check --
------------------------------
function Make_Transportable_Check
(Loc : Source_Ptr;
Expr : Node_Id) return Node_Id is
begin
return
Make_Raise_Program_Error (Loc,
Condition =>
Make_Op_Not (Loc,
Build_Get_Transportable (Loc,
Make_Selected_Component (Loc,
Prefix => Expr,
Selector_Name => Make_Identifier (Loc, Name_uTag)))),
Reason => PE_Non_Transportable_Actual);
end Make_Transportable_Check;
-----------------------------
-- Make_Selected_Component --
-----------------------------
@ -6873,17 +6954,17 @@ package body Exp_Dist is
-- - 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
-- and will dispatch the call to the right subprogram;
-- - a receiving stub for any subprogram visible in the package
-- - a receiving stub for each subprogram visible in the package
-- spec. This stub will read all the parameters from the stream,
-- and put the result as well as the exception occurrence in the
-- output stream
-- 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
-- by calling System.Partition_Interface.Register_Receiving_Stub.
Build_RPC_Receiver_Body (
RPC_Receiver => Pkg_RPC_Receiver,
@ -6922,41 +7003,6 @@ package body Exp_Dist is
New_Occurrence_Of (Is_Local, Loc),
New_Occurrence_Of (Local_Address, Loc))));
-- Determine whether the reference that was used to make
-- the call was the base RCI reference (in which case
-- Local_Address is 0, and the method identifier from the
-- request must be used to determine which subprogram is
-- called) or a reference identifying one particular subprogram
-- (in which case Local_Address is the address of that
-- subprogram, and the method name from the request is
-- ignored).
-- In each case, cascaded elsifs are used to determine the
-- proper subprogram index. Using hash tables might be
-- more efficient.
Append_To (Pkg_RPC_Receiver_Statements,
Make_Implicit_If_Statement (Pkg_Spec,
Condition =>
Make_Op_Ne (Loc,
Left_Opnd => New_Occurrence_Of (Local_Address, Loc),
Right_Opnd => New_Occurrence_Of (RTE (RE_Null_Address), Loc)),
Then_Statements => New_List (
Make_Implicit_If_Statement (Pkg_Spec,
Condition =>
New_Occurrence_Of (Standard_False, Loc),
Then_Statements => New_List (
Make_Null_Statement (Loc)),
Elsif_Parts =>
Dispatch_On_Address)),
Else_Statements => New_List (
Make_Implicit_If_Statement (Pkg_Spec,
Condition =>
New_Occurrence_Of (Standard_False, Loc),
Then_Statements => New_List (
Make_Null_Statement (Loc)),
Elsif_Parts =>
Dispatch_On_Name))));
-- 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.
@ -7076,6 +7122,88 @@ package body Exp_Dist is
Next (Current_Declaration);
end loop;
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => Subp_Info_Array,
Constant_Present => True,
Aliased_Present => True,
Object_Definition =>
Make_Subtype_Indication (Loc,
Subtype_Mark =>
New_Occurrence_Of (RTE (RE_RCI_Subp_Info_Array), Loc),
Constraint =>
Make_Index_Or_Discriminant_Constraint (Loc,
New_List (
Make_Range (Loc,
Low_Bound => Make_Integer_Literal (Loc,
First_RCI_Subprogram_Id),
High_Bound =>
Make_Integer_Literal (Loc,
First_RCI_Subprogram_Id
+ List_Length (Subp_Info_List) - 1)))))));
if Present (First (Subp_Info_List)) then
Set_Expression (Last (Decls),
Make_Aggregate (Loc,
Component_Associations => Subp_Info_List));
-- Generate the dispatch statement to determine the subprogram id
-- of the called subprogram.
-- We first test whether the reference that was used to make the
-- call was the base RCI reference (in which case Local_Address is
-- zero, and the method identifier from the request must be used
-- to determine which subprogram is called) or a reference
-- identifying one particular subprogram (in which case
-- Local_Address is the address of that subprogram, and the
-- method name from the request is ignored). The latter occurs
-- for the case of a call through a remote access-to-subprogram.
-- In each case, cascaded elsifs are used to determine the proper
-- subprogram index. Using hash tables might be more efficient.
Append_To (Pkg_RPC_Receiver_Statements,
Make_Implicit_If_Statement (Pkg_Spec,
Condition =>
Make_Op_Ne (Loc,
Left_Opnd => New_Occurrence_Of
(Local_Address, Loc),
Right_Opnd => New_Occurrence_Of
(RTE (RE_Null_Address), Loc)),
Then_Statements => New_List (
Make_Implicit_If_Statement (Pkg_Spec,
Condition =>
New_Occurrence_Of (Standard_False, Loc),
Then_Statements => New_List (
Make_Null_Statement (Loc)),
Elsif_Parts =>
Dispatch_On_Address)),
Else_Statements => New_List (
Make_Implicit_If_Statement (Pkg_Spec,
Condition =>
New_Occurrence_Of (Standard_False, Loc),
Then_Statements => New_List (
Make_Null_Statement (Loc)),
Elsif_Parts =>
Dispatch_On_Name))));
else
-- For a degenerate RCI with no visible subprograms,
-- Subp_Info_List has zero length, and the declaration is for an
-- empty array, in which case no initialization aggregate must be
-- generated. We do not generate a Dispatch_Statement either.
-- No initialization provided: remove CONSTANT so that the
-- declaration is not an incomplete deferred constant.
Set_Constant_Present (Last (Decls), False);
end if;
-- Analyze Subp_Info_Array declaration
Analyze (Last (Decls));
-- 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.
@ -7097,29 +7225,8 @@ package body Exp_Dist is
New_Occurrence_Of (Subp_Index, Loc),
Alternatives => Pkg_RPC_Receiver_Cases));
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => Subp_Info_Array,
Constant_Present => True,
Aliased_Present => True,
Object_Definition =>
Make_Subtype_Indication (Loc,
Subtype_Mark =>
New_Occurrence_Of (RTE (RE_RCI_Subp_Info_Array), Loc),
Constraint =>
Make_Index_Or_Discriminant_Constraint (Loc,
New_List (
Make_Range (Loc,
Low_Bound => Make_Integer_Literal (Loc,
First_RCI_Subprogram_Id),
High_Bound =>
Make_Integer_Literal (Loc,
First_RCI_Subprogram_Id
+ List_Length (Subp_Info_List) - 1))))),
Expression =>
Make_Aggregate (Loc,
Component_Associations => Subp_Info_List)));
Analyze (Last (Decls));
-- Pkg_RPC_Receiver body is now complete: insert it into the tree and
-- analyze it.
Append_To (Decls, Pkg_RPC_Receiver_Body);
Analyze (Last (Decls));
@ -8183,6 +8290,18 @@ package body Exp_Dist is
Name => Called_Subprogram,
Parameter_Associations => Parameter_List)));
if Is_Class_Wide_Type (Etyp) then
-- For a remote call to a function with a class-wide type,
-- check that the returned value satisfies the requirements
-- of E.4(18).
Append_To (Inner_Decls,
Make_Transportable_Check (Loc,
New_Occurrence_Of (Result, Loc)));
end if;
Set_Etype (Result, Etyp);
Append_To (After_Statements,
Make_Procedure_Call_Statement (Loc,

11
gcc/ada/exp_dist.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2007, 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- --
@ -27,6 +27,7 @@
-- This package contains utility routines used for the generation of the
-- stubs relevant to the distribution annex.
with Namet; use Namet;
with Types; use Types;
package Exp_Dist is
@ -110,4 +111,12 @@ package Exp_Dist is
-- not be generated in the package spec because this would cause an
-- incorrect attempt to freeze Taft amendment types declared in the spec.
function Make_Transportable_Check
(Loc : Source_Ptr;
Expr : Node_Id) return Node_Id;
-- Generate a check that the given expression (an actual in a remote
-- subprogram call, or the return value of a function in the context of
-- a remote call) satisfies the requirements for being transportable
-- across partitions, raising Program_Error if it does not.
end Exp_Dist;