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
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 --
-----------------------
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;
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;
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;
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)));
and then Chars (P) = Chars (Selector)
then
Id := S;
- goto found;
+ goto Found;
end if;
end if;
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;
-- --
-- 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- --
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 --
------------------------
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;
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
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 (
return;
end if;
- if not Expander_Active then
+ if not Expander_Active or else Get_PCS_Name = Name_No_DSA then
return;
end if;
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
-- --
-- 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- --
-- 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;
-- 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
-- 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
-- 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,
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);
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;
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.
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)),
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
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))
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);
if Nkind (Entry_Name) = N_Selected_Component then
- -- Simple entry call.
+ -- Simple entry call
Nam := Entity (Selector_Name (Entry_Name));
Obj := Prefix (Entry_Name);
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));
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));
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;
and then (Etype (Right_Opnd (Operand)) = Universal_Real
or else Etype (Left_Opnd (Operand)) = Universal_Real)
then
+ -- Return if expression is ambiguous
+
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 nothing else, the available fixed type is Duration
+
+ else
Set_Etype (Operand, Standard_Duration);
end if;
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);
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
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.
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
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)
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;
OSDN Git Service
