Patchwork [Ada] New pragma/aspect Remote_Access_Type

login
register
mail settings
Submitter Arnaud Charlet
Date Jan. 30, 2012, 10:24 a.m.
Message ID <20120130102425.GA4399@adacore.com>
Download mbox | patch
Permalink /patch/138541/
State New
Headers show

Comments

Arnaud Charlet - Jan. 30, 2012, 10:24 a.m.
This change introduces a new implementation defined pragma, and an associated
implementation defined aspect: Remote_Access_Type. This pragma allows the
definition of generic units allowing RACWs as actuals for generic formal
access types.

Tested on x86_64-pc-linux-gnu, committed on trunk

2012-01-30  Thomas Quinot  <quinot@adacore.com>

	* gnat_rm.texi, sem_dist.adb, sem_dist.ads, einfo.ads, sem_prag.adb,
	sem_ch12.adb, sem_attr.adb, aspects.adb, aspects.ads, par-prag.adb,
	sem_cat.adb, snames.ads-tmpl (Sem_Dist.Is_Valid_Remote_Object_Type):
	New subprogram (extracted from
	Sem_Cat.Validate_Remote_Access_Object_Type_Declaration).
	(Einfo.Is_Remote_Types): Now applies to generic types. Update
	documentation accordingly.
	(Sem_Ch12.Analyze_Associations): A RACW type is acceptable as
	actual for a formal type to which a pragma Remote_Access_Type
	applies.
	(Aspects, Par.Prag, Sem_Prag): Support for new pramga/aspect
	Remote_Access_Type.
	(Sem_Attr.Analyze_Attribute, case Stub_Type): Attribute can
	be applied to a generic type if pragma Remote_Access_Type
	applies, in which case the type of the attribute is
	System.Partition_Interface.RACW_Stub_Type.

Patch

Index: gnat_rm.texi
===================================================================
--- gnat_rm.texi	(revision 183694)
+++ gnat_rm.texi	(working copy)
@@ -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
Index: sem_dist.adb
===================================================================
--- sem_dist.adb	(revision 183694)
+++ sem_dist.adb	(working copy)
@@ -6,7 +6,7 @@ 
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2010, Free Software Foundation, Inc.         --
+--          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 --
    ------------------------------------
Index: sem_dist.ads
===================================================================
--- sem_dist.ads	(revision 183694)
+++ sem_dist.ads	(working copy)
@@ -6,7 +6,7 @@ 
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2008, Free Software Foundation, Inc.         --
+--          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
Index: einfo.ads
===================================================================
--- einfo.ads	(revision 183694)
+++ einfo.ads	(working copy)
@@ -6,7 +6,7 @@ 
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2011, Free Software Foundation, Inc.         --
+--          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
Index: sem_prag.adb
===================================================================
--- sem_prag.adb	(revision 183694)
+++ sem_prag.adb	(working copy)
@@ -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,
Index: sem_ch12.adb
===================================================================
--- sem_ch12.adb	(revision 183694)
+++ sem_ch12.adb	(working copy)
@@ -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 =>
Index: sem_attr.adb
===================================================================
--- sem_attr.adb	(revision 183694)
+++ sem_attr.adb	(working copy)
@@ -6,7 +6,7 @@ 
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2011, Free Software Foundation, Inc.         --
+--          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");
Index: aspects.adb
===================================================================
--- aspects.adb	(revision 183694)
+++ aspects.adb	(working copy)
@@ -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,
Index: aspects.ads
===================================================================
--- aspects.ads	(revision 183694)
+++ aspects.ads	(working copy)
@@ -6,7 +6,7 @@ 
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---         Copyright (C) 2010-2012, Free Software Foundation, Inc.          --
+--          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,
Index: par-prag.adb
===================================================================
--- par-prag.adb	(revision 183694)
+++ par-prag.adb	(working copy)
@@ -6,7 +6,7 @@ 
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2011, Free Software Foundation, Inc.         --
+--          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            |
Index: sem_cat.adb
===================================================================
--- sem_cat.adb	(revision 183694)
+++ sem_cat.adb	(working copy)
@@ -6,7 +6,7 @@ 
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2011, Free Software Foundation, Inc.         --
+--          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
Index: snames.ads-tmpl
===================================================================
--- snames.ads-tmpl	(revision 183694)
+++ snames.ads-tmpl	(working copy)
@@ -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,