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

exp_dist.adb (Get_PCS_Name): Move from Exp_Dist body to Sem_Dist spec...

Browse Source 
2005-03-17  Thomas Quinot  <quinot@adacore.com>

	* exp_dist.adb (Get_PCS_Name): Move from Exp_Dist body to Sem_Dist
	spec, to make this predicate available to other units.

	* rtsfind.adb (Check_RPC): Use Sem_Dist.Get_PCS_Name instead of
	reimplementing it.

	* sem_ch8.adb: Disable expansion of remote access-to-subprogram types
	when no distribution runtime library is available.

	* sem_res.adb, sem_dist.adb: Disable expansion of remote
	access-to-subprogram types when no distribution runtime library is
	available.
	(Get_PCS_Name): Move from Exp_Dist body to Sem_Dist spec, to make this
	predicate available to other units.

	* sem_dist.ads (Get_PCS_Name): Move from Exp_Dist body to Sem_Dist
	spec, to make this predicate available to other units.

From-SVN: r96668
This commit is contained in:
Thomas Quinot 2005-03-18 12:49:26 +01:00 committed by Arnaud Charlet
parent 2ccf2fb35e
commit a77842bdf9
6 changed files with 123 additions and 117 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
gcc/ada/exp_dist.adb
View File

@ -152,11 +152,6 @@ package body Exp_Dist is
pragma Warnings (Off, Get_Subprogram_Id);
-- One homonym only is unreferenced (specific to the GARLIC version)
function Get_PCS_Name return PCS_Names;
-- Return the name of a literal of type
-- System.Partition_Interface.DSA_Implementation_Type
-- indicating what PCS is currently in use.
procedure Add_RAS_Dereference_TSS (N : Node_Id);
-- Add a subprogram body for RAS Dereference TSS
@ -4785,18 +4780,6 @@ package body Exp_Dist is
Selector_Name => Make_Identifier (Loc, Selector_Name));
end Make_Selected_Component;
------------------
-- Get_PCS_Name --
------------------
function Get_PCS_Name return PCS_Names is
PCS_Name : constant PCS_Names :=
Chars (Entity (Expression
(Parent (RTE (RE_DSA_Implementation)))));
begin
return PCS_Name;
end Get_PCS_Name;
-----------------------
-- Get_Subprogram_Id --
-----------------------

19
gcc/ada/rtsfind.adb
View File

@ -43,6 +43,7 @@ with Opt; use Opt;
with Restrict; use Restrict;
with Sem; use Sem;
with Sem_Ch7; use Sem_Ch7;
with Sem_Dist; use Sem_Dist;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Stand; use Stand;
@ -838,20 +839,12 @@ package body Rtsfind is
E = RE_Params_Stream_Type
or else
E = RE_Request_Access)
and then Get_PCS_Name = Name_No_DSA
then
declare
DSA_Implementation : constant Entity_Id :=
RTE (RE_DSA_Implementation);
begin
if Chars (Entity (Expression
(Parent (DSA_Implementation)))) = Name_No_DSA
then
Set_Standard_Error;
Write_Str ("distribution feature not supported");
Write_Eol;
raise Unrecoverable_Error;
end if;
end;
Set_Standard_Error;
Write_Str ("distribution feature not supported");
Write_Eol;
raise Unrecoverable_Error;
end if;
end Check_RPC;

12
gcc/ada/sem_ch8.adb
View File

@ -50,6 +50,7 @@ with Sem_Ch4; use Sem_Ch4;
with Sem_Ch6; use Sem_Ch6;
with Sem_Ch12; use Sem_Ch12;
with Sem_Disp; use Sem_Disp;
with Sem_Dist; use Sem_Dist;
with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util;
with Sem_Type; use Sem_Type;
@ -3235,6 +3236,7 @@ package body Sem_Ch8 is
if Comes_From_Source (N)
and then Is_Remote_Access_To_Subprogram_Type (E)
and then Expander_Active
and then Get_PCS_Name /= Name_No_DSA
then
Rewrite (N,
New_Occurrence_Of (Equivalent_Type (E), Sloc (N)));
@ -3540,7 +3542,7 @@ package body Sem_Ch8 is
and then Chars (P) = Chars (Selector)
then
Id := S;
goto found;
goto Found;
end if;
end if;
@ -3610,10 +3612,16 @@ package body Sem_Ch8 is
end if;
end if;
<<found>>
<<Found>>
if Comes_From_Source (N)
and then Is_Remote_Access_To_Subprogram_Type (Id)
and then Present (Equivalent_Type (Id))
then
-- If we are not actually generating distribution code (i.e.
-- the current PCS is the dummy non-distributed version), then
-- the Equivalent_Type will be missing, and Id should be treated
-- as a regular access-to-subprogram type.
Id := Equivalent_Type (Id);
Set_Chars (Selector, Chars (Id));
end if;

71
gcc/ada/sem_dist.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2004, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2005, 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- --
@ -199,6 +199,18 @@ package body Sem_Dist is
return End_String;
end Full_Qualified_Name;
------------------
-- Get_PCS_Name --
------------------
function Get_PCS_Name return PCS_Names is
PCS_Name : constant PCS_Names :=
Chars (Entity (Expression
(Parent (RTE (RE_DSA_Implementation)))));
begin
return PCS_Name;
end Get_PCS_Name;
------------------------
-- Is_All_Remote_Call --
------------------------
@ -341,7 +353,7 @@ package body Sem_Dist is
Remote_Subp := Entity (Prefix (N));
if not Expander_Active then
if not Expander_Active or else Get_PCS_Name = Name_No_DSA then
return;
end if;
@ -429,6 +441,33 @@ package body Sem_Dist is
Fat_Type_Decl : Node_Id;
begin
Is_Degenerate := False;
Parameter := First (Parameter_Specifications (Type_Def));
while Present (Parameter) loop
if Nkind (Parameter_Type (Parameter)) = N_Access_Definition then
Error_Msg_N ("formal parameter& has anonymous access type?",
Defining_Identifier (Parameter));
Is_Degenerate := True;
exit;
end if;
Next (Parameter);
end loop;
if Is_Degenerate then
Error_Msg_NE (
"remote access-to-subprogram type& can only be null?",
Defining_Identifier (Parameter), User_Type);
-- The only legal value for a RAS with a formal parameter of an
-- anonymous access type is null, because it cannot be
-- subtype-Conformant with any legal remote subprogram declaration.
-- In this case, we cannot generate a corresponding primitive
-- operation.
end if;
if Get_PCS_Name = Name_No_DSA then
return;
end if;
-- The tagged private type, primitive operation and RACW
-- type associated with a RAS need to all be declared in
@ -457,29 +496,7 @@ package body Sem_Dist is
Null_Present => True,
Component_List => Empty)));
Is_Degenerate := False;
Parameter := First (Parameter_Specifications (Type_Def));
Parameters : while Present (Parameter) loop
if Nkind (Parameter_Type (Parameter)) = N_Access_Definition then
Error_Msg_N ("formal parameter& has anonymous access type?",
Defining_Identifier (Parameter));
Is_Degenerate := True;
exit Parameters;
end if;
Next (Parameter);
end loop Parameters;
if Is_Degenerate then
Error_Msg_NE (
"remote access-to-subprogram type& can only be null?",
Defining_Identifier (Parameter), User_Type);
-- The only legal value for a RAS with a formal parameter of an
-- anonymous access type is null, because it cannot be
-- subtype-Conformant with any legal remote subprogram declaration.
-- In this case, we cannot generate a corresponding primitive
-- operation.
else
if not Is_Degenerate then
Append_To (Vis_Decls,
Make_Abstract_Subprogram_Declaration (Loc,
Specification => Build_RAS_Primitive_Specification (
@ -595,7 +612,7 @@ package body Sem_Dist is
return;
end if;
if not Expander_Active then
if not Expander_Active or else Get_PCS_Name = Name_No_DSA then
return;
end if;
@ -685,7 +702,7 @@ package body Sem_Dist is
Target_Type : Entity_Id;
begin
if not Expander_Active then
if not Expander_Active or else Get_PCS_Name = Name_No_DSA then
return False;
elsif Ekind (Typ) = E_Access_Subprogram_Type

51
gcc/ada/sem_dist.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2005 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- --
@ -26,15 +26,20 @@
-- Semantic processing for distribution annex facilities
with Types; use Types;
with Snames; use Snames;
with Types; use Types;
package Sem_Dist is
function Get_PCS_Name return PCS_Names;
-- Return the name of a literal of type System.Partition_Interface.
-- DSA_Implementation_Type indicating what PCS is currently in use.
procedure Add_Stub_Constructs (N : Node_Id);
-- Create the stubs constructs for a remote call interface package
-- specification or body or for a shared passive specification. For
-- caller stubs, expansion takes place directly in the specification and
-- no additional compilation unit is created.
-- specification or body or for a shared passive specification. For caller
-- stubs, expansion takes place directly in the specification and no
-- additional compilation unit is created.
function Build_RAS_Primitive_Specification
(Subp_Spec : Node_Id;
@ -59,35 +64,33 @@ package Sem_Dist is
-- whose return type is New_Type.
procedure Process_Remote_AST_Declaration (N : Node_Id);
-- Given N, an access to subprogram type declaration node in RCI or
-- remote types unit, build a new record (fat pointer) type declaration
-- using the old Defining_Identifier of N and a link to the old
-- declaration node N whose Defining_Identifier is changed.
-- We also construct declarations of two subprograms in the unit
-- specification which handle remote access to subprogram type
-- (fat pointer) dereference and the unit receiver that handles
-- remote calls (from remote access to subprogram type values.)
-- Given N, an access to subprogram type declaration node in RCI or remote
-- types unit, build a new record (fat pointer) type declaration using the
-- old Defining_Identifier of N and a link to the old declaration node N
-- whose Defining_Identifier is changed. We also construct declarations of
-- two subprograms in the unit specification which handle remote access to
-- subprogram type (fat pointer) dereference and the unit receiver that
-- handles remote calls (from remote access to subprogram type values.)
function Remote_AST_E_Dereference (P : Node_Id) return Boolean;
-- If the prefix of an explicit dereference is a record type that
-- represent the fat pointer for an Remote access to subprogram, in
-- the context of a call, rewrite the enclosing call node into a
-- remote call, the first actual of which is the fat pointer. Return
-- true if the context is correct and the transformation took place.
-- represent the fat pointer for an Remote access to subprogram, in the
-- context of a call, rewrite the enclosing call node into remote call,
-- the first actual of which is the fat pointer. Return true if the
-- context is correct and the transformation took place.
function Remote_AST_I_Dereference (P : Node_Id) return Boolean;
-- If P is a record type that represents the fat pointer for a remote
-- access to subprogram, and P is the prefix of a call, insert an
-- explicit dereference and perform the transformation described for
-- the previous function.
-- access to subprogram, and P is the prefix of a call, insert an explicit
-- dereference and perform the transformation described for the previous
-- function.
function Remote_AST_Null_Value
(N : Node_Id;
Typ : Entity_Id) return Boolean;
-- If N is a null value and Typ a remote access to subprogram type,
-- this function will check if null needs to be replaced with an
-- aggregate and will return True in this case. Otherwise, it will
-- return False.
-- If N is a null value and Typ a remote access to subprogram type, this
-- function will check if null needs to be replaced with an aggregate and
-- will return True in this case. Otherwise, it will return False.
function Package_Specification_Of_Scope (E : Entity_Id) return Node_Id;
-- Return the N_Package_Specification corresponding to a scope E

70
gcc/ada/sem_res.adb
View File

@ -168,7 +168,7 @@ package body Sem_Res is
-- by other node rewriting procedures.
procedure Resolve_Actuals (N : Node_Id; Nam : Entity_Id);
-- Resolve actuals of call, and add default expressions for missing ones.
-- Resolve actuals of call, and add default expressions for missing ones
procedure Resolve_Entry_Call (N : Node_Id; Typ : Entity_Id);
-- Called from Resolve_Call, when the prefix denotes an entry or element
@ -182,7 +182,7 @@ package body Sem_Res is
-- to the corresponding predefined operator, with suitable conversions.
procedure Resolve_Intrinsic_Unary_Operator (N : Node_Id; Typ : Entity_Id);
-- Ditto, for unary operators (only arithmetic ones).
-- Ditto, for unary operators (only arithmetic ones)
procedure Rewrite_Operator_As_Call (N : Node_Id; Nam : Entity_Id);
-- If an operator node resolves to a call to a user-defined operator,
@ -371,14 +371,14 @@ package body Sem_Res is
D : Node_Id;
begin
-- Any use in a default expression is legal.
-- Any use in a default expression is legal
if In_Default_Expression then
null;
elsif Nkind (PN) = N_Range then
-- Discriminant cannot be used to constrain a scalar type.
-- Discriminant cannot be used to constrain a scalar type
P := Parent (PN);
@ -1320,7 +1320,7 @@ package body Sem_Res is
Full_Analysis := Save_Full_Analysis;
end Pre_Analyze_And_Resolve;
-- Version without context type.
-- Version without context type
procedure Pre_Analyze_And_Resolve (N : Node_Id) is
Save_Full_Analysis : constant Boolean := Full_Analysis;
@ -1534,17 +1534,9 @@ package body Sem_Res is
Is_Remote : Boolean := True;
begin
-- Check that Typ is a fat pointer with a reference to a RAS as
-- original access type.
-- Check that Typ is a remote access-to-subprogram type
if
(Ekind (Typ) = E_Access_Subprogram_Type
and then Present (Equivalent_Type (Typ)))
or else
(Ekind (Typ) = E_Record_Type
and then Present (Corresponding_Remote_Type (Typ)))
then
if Is_Remote_Access_To_Subprogram_Type (Typ) then
-- Prefix (N) must statically denote a remote subprogram
-- declared in a package specification.
@ -1581,6 +1573,7 @@ package body Sem_Res is
or else Attr = Attribute_Unchecked_Access
or else Attr = Attribute_Unrestricted_Access)
and then Expander_Active
and then Get_PCS_Name /= Name_No_DSA
then
Check_Subtype_Conformant
(New_Id => Entity (Prefix (N)),
@ -2020,7 +2013,7 @@ package body Sem_Res is
elsif Nkind (Name (N)) = N_Selected_Component then
-- Protected operation: retrieve operation name.
-- Protected operation: retrieve operation name
Subp_Name := Selector_Name (Name (N));
else
@ -2411,7 +2404,7 @@ package body Sem_Res is
else
Set_Parent (Actval, N);
-- See note above concerning aggregates.
-- See note above concerning aggregates
if Nkind (Actval) = N_Aggregate
and then Has_Discriminants (Etype (Actval))
@ -3131,13 +3124,13 @@ package body Sem_Res is
elsif Etype (N) = T
and then B_Typ /= Universal_Fixed
then
-- Not a mixed-mode operation. Resolve with context.
-- Not a mixed-mode operation, resolve with context
Resolve (N, B_Typ);
elsif Etype (N) = Any_Fixed then
-- N may itself be a mixed-mode operation, so use context type.
-- N may itself be a mixed-mode operation, so use context type
Resolve (N, B_Typ);
@ -4512,7 +4505,7 @@ package body Sem_Res is
if Nkind (Entry_Name) = N_Selected_Component then
-- Simple entry call.
-- Simple entry call
Nam := Entity (Selector_Name (Entry_Name));
Obj := Prefix (Entry_Name);
@ -4520,7 +4513,7 @@ package body Sem_Res is
else pragma Assert (Nkind (Entry_Name) = N_Indexed_Component);
-- Call to member of entry family.
-- Call to member of entry family
Nam := Entity (Selector_Name (Prefix (Entry_Name)));
Obj := Prefix (Prefix (Entry_Name));
@ -4941,7 +4934,7 @@ package body Sem_Res is
Array_Type := Designated_Type (Array_Type);
end if;
-- If name was overloaded, set component type correctly now.
-- If name was overloaded, set component type correctly now
Set_Etype (N, Component_Type (Array_Type));
@ -5247,7 +5240,7 @@ package body Sem_Res is
return;
end if;
-- The null literal takes its type from the context.
-- The null literal takes its type from the context
Set_Etype (N, Typ);
end Resolve_Null;
@ -6347,11 +6340,14 @@ package body Sem_Res is
and then (Etype (Right_Opnd (Operand)) = Universal_Real
or else Etype (Left_Opnd (Operand)) = Universal_Real)
then
if Unique_Fixed_Point_Type (N) = Any_Type then
return; -- expression is ambiguous.
else
-- If nothing else, the available fixed type is Duration.
-- Return if expression is ambiguous
if Unique_Fixed_Point_Type (N) = Any_Type then
return;
-- If nothing else, the available fixed type is Duration
else
Set_Etype (Operand, Standard_Duration);
end if;
@ -6548,7 +6544,7 @@ package body Sem_Res is
Opnd_Type : constant Entity_Id := Etype (Operand);
begin
-- Resolve operand using its own type.
-- Resolve operand using its own type
Resolve (Operand, Opnd_Type);
Eval_Unchecked_Conversion (N);
@ -6770,7 +6766,11 @@ package body Sem_Res is
Scop : Entity_Id;
procedure Fixed_Point_Error;
-- If true ambiguity, give details.
-- If true ambiguity, give details
-----------------------
-- Fixed_Point_Error --
-----------------------
procedure Fixed_Point_Error is
begin
@ -6779,6 +6779,8 @@ package body Sem_Res is
Error_Msg_NE ("\possible interpretation as}", N, T2);
end Fixed_Point_Error;
-- Start of processing for Unique_Fixed_Point_Type
begin
-- The operations on Duration are visible, so Duration is always a
-- possible interpretation.
@ -6810,7 +6812,7 @@ package body Sem_Res is
Scop := Scope (Scop);
end loop;
-- Look for visible fixed type declarations in the context.
-- Look for visible fixed type declarations in the context
Item := First (Context_Items (Cunit (Current_Sem_Unit)));
while Present (Item) loop
@ -6896,15 +6898,15 @@ package body Sem_Res is
Opnd_Type : Entity_Id) return Boolean
is
begin
-- Upward conversions are allowed (RM 4.6(22)).
-- Upward conversions are allowed (RM 4.6(22))
if Covers (Target_Type, Opnd_Type)
or else Is_Ancestor (Target_Type, Opnd_Type)
then
return True;
-- Downward conversion are allowed if the operand is
-- is class-wide (RM 4.6(23)).
-- Downward conversion are allowed if the operand is class-wide
-- (RM 4.6(23)).
elsif Is_Class_Wide_Type (Opnd_Type)
and then Covers (Opnd_Type, Target_Type)
@ -7285,7 +7287,7 @@ package body Sem_Res is
elsif Is_Tagged_Type (Target_Type) then
return Valid_Tagged_Conversion (Target_Type, Opnd_Type);
-- Types derived from the same root type are convertible.
-- Types derived from the same root type are convertible
elsif Root_Type (Target_Type) = Root_Type (Opnd_Type) then
return True;