===================================================================
@@ -186,6 +186,7 @@
* Pragma Profile (Restricted)::
* Pragma Psect_Object::
* Pragma Pure_Function::
+* Pragma Remote_Access_Type::
* Pragma Restriction_Warnings::
* Pragma Shared::
* Pragma Short_Circuit_And_Or::
@@ -824,6 +825,7 @@
* Pragma Profile (Restricted)::
* Pragma Psect_Object::
* Pragma Pure_Function::
+* Pragma Remote_Access_Type::
* Pragma Restriction_Warnings::
* Pragma Shared::
* Pragma Short_Circuit_And_Or::
@@ -4479,6 +4481,32 @@
unit is not a Pure unit in the categorization sense. So for example, a function
thus marked is free to @code{with} non-pure units.
+@node Pragma Remote_Access_Type
+@unnumberedsec Pragma Remote_Access_Type
+@findex Remote_Access_Type
+@noindent
+Syntax:
+
+@smallexample @c ada
+pragma Remote_Access_Type ([Entity =>] formal_access_type_LOCAL_NAME);
+@end smallexample
+
+@noindent
+This pragma appears in the formal part of a generic declaration.
+It specifies an exception to the RM rule from E.2.2(17/2), which forbids
+the use of a remote access to class-wide type as actual for a formal
+access type.
+
+When this pragma applies to a formal access type @code{Entity}, that
+type is treated as a remote access to class-wide type in the generic.
+It must be a formal general access type, and its designated type must
+be the class-wide type of a formal tagged limited private type from the
+same generic declaration.
+
+In the generic unit, the formal type is subject to all restrictions
+pertaining to remote access to class-wide types. At instantiation, the
+actual type must be a remote access to class-wide type.
+
@node Pragma Restriction_Warnings
@unnumberedsec Pragma Restriction_Warnings
@findex Restriction_Warnings
@@ -16803,6 +16831,7 @@
@item @code{Predicate} @tab
@item @code{Preelaborable_Initialization} @tab
@item @code{Pure_Function} @tab -- GNAT
+@item @code{Remote_Access_Type} @tab -- GNAT
@item @code{Shared} @tab -- GNAT
@item @code{Size} @tab
@item @code{Storage_Pool} @tab
===================================================================
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
+-- Copyright (C) 1992-2012, 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- --
@@ -287,6 +287,50 @@
end case;
end Is_RACW_Stub_Type_Operation;
+ ---------------------------------
+ -- Is_Valid_Remote_Object_Type --
+ ---------------------------------
+
+ function Is_Valid_Remote_Object_Type (E : Entity_Id) return Boolean is
+ P : constant Node_Id := Parent (E);
+
+ begin
+ pragma Assert (Is_Tagged_Type (E));
+
+ -- Simple case: a limited private type
+
+ if Nkind (P) = N_Private_Type_Declaration
+ and then Is_Limited_Record (E)
+ then
+ return True;
+
+ -- AI05-0060 (Binding Interpretation): A limited interface is a legal
+ -- ancestor for the designated type of an RACW type.
+
+ elsif Is_Limited_Record (E) and then Is_Limited_Interface (E) then
+ return True;
+
+ -- A generic tagged limited type is a valid candidate. Limitedness will
+ -- be checked again on the actual at instantiation point.
+
+ elsif Nkind (P) = N_Formal_Type_Declaration
+ and then Ekind (E) = E_Record_Type_With_Private
+ and then Is_Generic_Type (E)
+ and then Is_Limited_Record (E)
+ then
+ return True;
+
+ -- A private extension declaration is a valid candidate if its parent
+ -- type is.
+
+ elsif Nkind (P) = N_Private_Extension_Declaration then
+ return Is_Valid_Remote_Object_Type (Etype (E));
+
+ else
+ return False;
+ end if;
+ end Is_Valid_Remote_Object_Type;
+
------------------------------------
-- Package_Specification_Of_Scope --
------------------------------------
===================================================================
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
+-- Copyright (C) 1992-2012, 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- --
@@ -40,6 +40,11 @@
-- (Exp_Dist.PCS_Version_Number) in Rtsfind.RTE.Check_RPC.
-- If no PCS version information is available, 0 is returned.
+ function Is_Valid_Remote_Object_Type (E : Entity_Id) return Boolean;
+ -- True if tagged type E is a valid candidate as the root type of the
+ -- designated type for a RACW, i.e. a tagged limited private type, or a
+ -- limited interface type, or a private extension of such a type.
+
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
===================================================================
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
+-- Copyright (C) 1992-2012, 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- --
@@ -2721,6 +2721,8 @@
-- Present in all entities. Set in E_Package and E_Generic_Package
-- entities to which a pragma Remote_Types is applied, and also on
-- entities declared in the visible part of the spec of such a package.
+-- Also set for generic formal types to which pragma Remote_Access_Type
+-- applies.
-- Is_Renaming_Of_Object (Flag112)
-- Present in all entities, set only for a variable or constant for
===================================================================
@@ -710,7 +710,7 @@
procedure Fix_Error (Msg : in out String);
-- This is called prior to issuing an error message. Msg is a string
- -- which typically contains the substring pragma. If the current pragma
+ -- that typically contains the substring "pragma". If the current pragma
-- comes from an aspect, each such "pragma" substring is replaced with
-- the characters "aspect", and if Error_Msg_Name_1 is Name_Precondition
-- (resp Name_Postcondition) it is changed to Name_Pre (resp Name_Post).
@@ -12890,6 +12890,39 @@
end if;
end Relative_Deadline;
+ ------------------------
+ -- Remote_Access_Type --
+ ------------------------
+
+ -- pragma Remote_Access_Type ([Entity =>] formal_type_LOCAL_NAME);
+
+ when Pragma_Remote_Access_Type => Remote_Access_Type : declare
+ E : Entity_Id;
+
+ begin
+ GNAT_Pragma;
+ Check_Arg_Count (1);
+ Check_Optional_Identifier (Arg1, Name_Entity);
+ Check_Arg_Is_Local_Name (Arg1);
+ E := Entity (Get_Pragma_Arg (Arg1));
+
+ if Nkind (Parent (E)) = N_Formal_Type_Declaration
+ and then Ekind (E) = E_General_Access_Type
+ and then Is_Class_Wide_Type (Directly_Designated_Type (E))
+ and then Scope (Root_Type (Directly_Designated_Type (E)))
+ = Scope (E)
+ and then Is_Valid_Remote_Object_Type
+ (Root_Type (Directly_Designated_Type (E)))
+ then
+ Set_Is_Remote_Types (E);
+
+ else
+ Error_Pragma_Arg
+ ("pragma% applies only to formal access to classwide types",
+ Arg1);
+ end if;
+ end Remote_Access_Type;
+
---------------------------
-- Remote_Call_Interface --
---------------------------
@@ -15071,6 +15104,7 @@
Pragma_Queuing_Policy => -1,
Pragma_Ravenscar => -1,
Pragma_Relative_Deadline => -1,
+ Pragma_Remote_Access_Type => -1,
Pragma_Remote_Call_Interface => -1,
Pragma_Remote_Types => -1,
Pragma_Restricted_Run_Time => -1,
===================================================================
@@ -1442,14 +1442,43 @@
end if;
-- A remote access-to-class-wide type is not a legal actual
- -- for a generic formal of an access type (E.2.2(17)).
+ -- for a generic formal of an access type (E.2.2(17/2)).
+ -- In GNAT an exception to this rule is introduced when
+ -- the formal is marked as remote using implementation
+ -- defined aspect/pragma Remote_Access_Type. In that case
+ -- the actual must be remote as well.
if Nkind (Analyzed_Formal) = N_Formal_Type_Declaration
and then
Nkind (Formal_Type_Definition (Analyzed_Formal)) =
N_Access_To_Object_Definition
then
- Validate_Remote_Access_To_Class_Wide_Type (Match);
+ declare
+ Formal_Ent : constant Entity_Id :=
+ Defining_Identifier (Analyzed_Formal);
+ begin
+ if Is_Remote_Access_To_Class_Wide_Type (Entity (Match))
+ = Is_Remote_Types (Formal_Ent)
+ then
+ -- Remoteness of formal and actual match
+
+ null;
+
+ elsif Is_Remote_Types (Formal_Ent) then
+
+ -- Remote formal, non-remote actual
+
+ Error_Msg_NE
+ ("actual for& must be remote", Match, Formal_Ent);
+
+ else
+ -- Non-remote formal, remote actual
+
+ Error_Msg_NE
+ ("actual for& may not be remote",
+ Match, Formal_Ent);
+ end if;
+ end;
end if;
when N_Formal_Subprogram_Declaration =>
===================================================================
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
+-- Copyright (C) 1992-2012, 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- --
@@ -4636,9 +4636,29 @@
Check_Type;
Check_E0;
- if Is_Remote_Access_To_Class_Wide_Type (P_Type) then
- Rewrite (N,
- New_Occurrence_Of (Corresponding_Stub_Type (P_Type), Loc));
+ if Is_Remote_Access_To_Class_Wide_Type (Base_Type (P_Type)) then
+
+ if not Is_Generic_Type (P_Type) then
+ -- For a real RACW [sub]type, use corresponding stub type
+
+ Rewrite (N,
+ New_Occurrence_Of
+ (Corresponding_Stub_Type (Base_Type (P_Type)), Loc));
+
+ else
+ -- For a generic type (that has been marked as an RACW using
+ -- the Remote_Access_Type aspect or pragma), use a generic RACW
+ -- stub type. Note that if the actual is not a remote access
+ -- type, the instantiation will fail.
+
+ -- Note: we go to the underlying type here because the view
+ -- returned by RTE (RE_RACW_Stub_Type) might be incomplete.
+
+ Rewrite (N,
+ New_Occurrence_Of
+ (Underlying_Type (RTE (RE_RACW_Stub_Type)), Loc));
+ end if;
+
else
Error_Attr_P
("prefix of% attribute must be remote access to classwide");
===================================================================
@@ -295,6 +295,7 @@
Aspect_Preelaborable_Initialization => Aspect_Preelaborable_Initialization,
Aspect_Priority => Aspect_Priority,
Aspect_Pure_Function => Aspect_Pure_Function,
+ Aspect_Remote_Access_Type => Aspect_Remote_Access_Type,
Aspect_Read => Aspect_Read,
Aspect_Shared => Aspect_Atomic,
Aspect_Size => Aspect_Size,
===================================================================
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
+-- Copyright (C) 2010-2012, 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- --
@@ -129,6 +129,7 @@
Aspect_Persistent_BSS, -- GNAT
Aspect_Preelaborable_Initialization,
Aspect_Pure_Function, -- GNAT
+ Aspect_Remote_Access_Type, -- GNAT
Aspect_Shared, -- GNAT (equivalent to Atomic)
Aspect_Suppress_Debug_Info, -- GNAT
Aspect_Unchecked_Union,
@@ -183,6 +184,7 @@
Aspect_Pure_05 => True,
Aspect_Pure_12 => True,
Aspect_Pure_Function => True,
+ Aspect_Remote_Access_Type => True,
Aspect_Shared => True,
Aspect_Suppress_Debug_Info => True,
Aspect_Test_Case => True,
@@ -299,6 +301,7 @@
-----------------------------------------
-- Table linking aspect names and id's
+ -- Shouldn't this be automatically generated in Snames???
Aspect_Names : constant array (Aspect_Id) of Name_Id := (
No_Aspect => No_Name,
@@ -357,6 +360,7 @@
Aspect_Pure_12 => Name_Pure_12,
Aspect_Pure_Function => Name_Pure_Function,
Aspect_Read => Name_Read,
+ Aspect_Remote_Access_Type => Name_Remote_Access_Type,
Aspect_Remote_Call_Interface => Name_Remote_Call_Interface,
Aspect_Remote_Types => Name_Remote_Types,
Aspect_Shared => Name_Shared,
===================================================================
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
+-- Copyright (C) 1992-2012, 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- --
@@ -1219,6 +1219,7 @@
Pragma_Pure_Function |
Pragma_Queuing_Policy |
Pragma_Relative_Deadline |
+ Pragma_Remote_Access_Type |
Pragma_Remote_Call_Interface |
Pragma_Remote_Types |
Pragma_Restricted_Run_Time |
===================================================================
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
+-- Copyright (C) 1992-2012, 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- --
@@ -37,6 +37,7 @@
with Sem; use Sem;
with Sem_Attr; use Sem_Attr;
with Sem_Aux; use Sem_Aux;
+with Sem_Dist; use Sem_Dist;
with Sem_Eval; use Sem_Eval;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
@@ -1661,63 +1662,9 @@
----------------------------------------------------
procedure Validate_Remote_Access_Object_Type_Declaration (T : Entity_Id) is
-
- function Is_Valid_Remote_Object_Type (E : Entity_Id) return Boolean;
- -- True if tagged type E is a valid candidate as the root type of the
- -- designated type for a RACW, i.e. a tagged limited private type, or a
- -- limited interface type, or a private extension of such a type.
-
- ---------------------------------
- -- Is_Valid_Remote_Object_Type --
- ---------------------------------
-
- function Is_Valid_Remote_Object_Type (E : Entity_Id) return Boolean is
- P : constant Node_Id := Parent (E);
-
- begin
- pragma Assert (Is_Tagged_Type (E));
-
- -- Simple case: a limited private type
-
- if Nkind (P) = N_Private_Type_Declaration
- and then Is_Limited_Record (E)
- then
- return True;
-
- -- AI05-0060 (Binding Interpretation): A limited interface is a legal
- -- ancestor for the designated type of an RACW type.
-
- elsif Is_Limited_Record (E) and then Is_Limited_Interface (E) then
- return True;
-
- -- A generic tagged limited type is a valid candidate. Limitedness
- -- will be checked again on the actual at instantiation point.
-
- elsif Nkind (P) = N_Formal_Type_Declaration
- and then Ekind (E) = E_Record_Type_With_Private
- and then Is_Generic_Type (E)
- and then Is_Limited_Record (E)
- then
- return True;
-
- -- A private extension declaration is a valid candidate if its parent
- -- type is.
-
- elsif Nkind (P) = N_Private_Extension_Declaration then
- return Is_Valid_Remote_Object_Type (Etype (E));
-
- else
- return False;
- end if;
- end Is_Valid_Remote_Object_Type;
-
- -- Local variables
-
Direct_Designated_Type : Entity_Id;
Desig_Type : Entity_Id;
- -- Start of processing for Validate_Remote_Access_Object_Type_Declaration
-
begin
-- We are called from Analyze_Full_Type_Declaration, and the Nkind of
-- the given node is N_Access_To_Object_Definition.
@@ -1793,19 +1740,17 @@
-- The actual parameter of generic instantiation must not be such a
-- type if the formal parameter is of an access type.
- -- On entry, there are five cases
+ -- On entry, there are several cases:
-- 1. called from sem_attr Analyze_Attribute where attribute name is
-- either Storage_Pool or Storage_Size.
-- 2. called from exp_ch4 Expand_N_Allocator
- -- 3. called from sem_ch12 Analyze_Associations
+ -- 3. called from sem_ch4 Analyze_Explicit_Dereference
- -- 4. called from sem_ch4 Analyze_Explicit_Dereference
+ -- 4. called from sem_res Resolve_Actuals
- -- 5. called from sem_res Resolve_Actuals
-
if K = N_Attribute_Reference then
E := Etype (Prefix (N));
@@ -1822,14 +1767,6 @@
return;
end if;
- elsif K in N_Has_Entity then
- E := Entity (N);
-
- if Is_Remote_Access_To_Class_Wide_Type (E) then
- Error_Msg_N ("incorrect remote type generic actual", N);
- return;
- end if;
-
-- This subprogram also enforces the checks in E.2.2(13). A value of
-- such type must not be dereferenced unless as controlling operand of
-- a dispatching call. Explicit dereferences not coming from source are
===================================================================
@@ -535,6 +535,7 @@
Name_Pure_12 : constant Name_Id := N + $; -- GNAT
Name_Pure_Function : constant Name_Id := N + $; -- GNAT
Name_Relative_Deadline : constant Name_Id := N + $; -- Ada 05
+ Name_Remote_Access_Type : constant Name_Id := N + $; -- GNAT
Name_Remote_Call_Interface : constant Name_Id := N + $;
Name_Remote_Types : constant Name_Id := N + $;
Name_Share_Generic : constant Name_Id := N + $; -- GNAT
@@ -1687,6 +1688,7 @@
Pragma_Pure_12,
Pragma_Pure_Function,
Pragma_Relative_Deadline,
+ Pragma_Remote_Access_Type,
Pragma_Remote_Call_Interface,
Pragma_Remote_Types,
Pragma_Share_Generic,