OSDN Git Service

2012-01-30 Robert Dewar <dewar@adacore.com>
authorcharlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4>
Mon, 30 Jan 2012 10:24:17 +0000 (10:24 +0000)
committercharlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4>
Mon, 30 Jan 2012 10:24:17 +0000 (10:24 +0000)
* a-cdlili.adb, a-cidlli.adb, a-cbdlli.adb: Minor reformatting.

2012-01-30  Olivier Hainque  <hainque@adacore.com>

* sigtramp-ppcvxw.c (CFI_COMMON_REGS): Add rule for r1 back +
comments.

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.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@183698 138bc75d-0d04-0410-961f-82ee72b054a4

17 files changed:
gcc/ada/ChangeLog
gcc/ada/a-cbdlli.adb
gcc/ada/a-cdlili.adb
gcc/ada/a-cidlli.adb
gcc/ada/aspects.adb
gcc/ada/aspects.ads
gcc/ada/einfo.ads
gcc/ada/gnat_rm.texi
gcc/ada/par-prag.adb
gcc/ada/sem_attr.adb
gcc/ada/sem_cat.adb
gcc/ada/sem_ch12.adb
gcc/ada/sem_dist.adb
gcc/ada/sem_dist.ads
gcc/ada/sem_prag.adb
gcc/ada/sigtramp-ppcvxw.c
gcc/ada/snames.ads-tmpl

index bfc7f2e..f0b84ca 100644 (file)
@@ -1,3 +1,31 @@
+2012-01-30  Robert Dewar  <dewar@adacore.com>
+
+       * a-cdlili.adb, a-cidlli.adb, a-cbdlli.adb: Minor reformatting.
+
+2012-01-30  Olivier Hainque  <hainque@adacore.com>
+
+       * sigtramp-ppcvxw.c (CFI_COMMON_REGS): Add rule for r1 back +
+       comments.
+
+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.
+
 2012-01-27  Eric Botcazou  <ebotcazou@adacore.com>
 
        * gcc-interface/decl.c (gnat_to_gnu_entity) <E_Procedure>: Do not set
index 28c9622..df9bf22 100644 (file)
@@ -2275,13 +2275,17 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
             return False;
          end if;
 
-         if Position.Node = L.First then  -- eliminates earlier disjunct
+         --  Eliminate earlier possibility
+
+         if Position.Node = L.First then
             return True;
          end if;
 
          pragma Assert (N (Position.Node).Prev /= 0);
 
-         if Position.Node = L.Last then  -- eliminates earlier disjunct
+         --  ELiminate another possibility
+
+         if Position.Node = L.Last then
             return True;
          end if;
 
index 1346e86..cfbcc36 100644 (file)
@@ -2009,6 +2009,7 @@ package body Ada.Containers.Doubly_Linked_Lists is
 
       declare
          L : List renames Position.Container.all;
+
       begin
          if L.Length = 0 then
             return False;
@@ -2030,23 +2031,21 @@ package body Ada.Containers.Doubly_Linked_Lists is
             return False;
          end if;
 
-         if Position.Node.Prev = null
-           and then Position.Node /= L.First
-         then
+         if Position.Node.Prev = null and then Position.Node /= L.First then
             return False;
          end if;
 
-         pragma Assert (Position.Node.Prev /= null
-                          or else Position.Node = L.First);
+         pragma Assert
+           (Position.Node.Prev /= null
+             or else Position.Node = L.First);
 
-         if Position.Node.Next = null
-           and then Position.Node /= L.Last
-         then
+         if Position.Node.Next = null and then Position.Node /= L.Last then
             return False;
          end if;
 
-         pragma Assert (Position.Node.Next /= null
-                          or else Position.Node = L.Last);
+         pragma Assert
+           (Position.Node.Next /= null
+             or else Position.Node = L.Last);
 
          if L.Length = 1 then
             return L.First = L.Last;
@@ -2075,13 +2074,11 @@ package body Ada.Containers.Doubly_Linked_Lists is
          if L.Length = 2 then
             if L.First.Next /= L.Last then
                return False;
-            end if;
-
-            if L.Last.Prev /= L.First then
+            elsif L.Last.Prev /= L.First then
                return False;
+            else
+               return True;
             end if;
-
-            return True;
          end if;
 
          if L.First.Next = L.Last then
@@ -2092,13 +2089,17 @@ package body Ada.Containers.Doubly_Linked_Lists is
             return False;
          end if;
 
-         if Position.Node = L.First then  -- eliminates earlier disjunct
+         --  Eliminate earlier possibility
+
+         if Position.Node = L.First then
             return True;
          end if;
 
          pragma Assert (Position.Node.Prev /= null);
 
-         if Position.Node = L.Last then  -- eliminates earlier disjunct
+         --  Eliminate earlier possibility
+
+         if Position.Node = L.Last then
             return True;
          end if;
 
@@ -2115,9 +2116,7 @@ package body Ada.Containers.Doubly_Linked_Lists is
          if L.Length = 3 then
             if L.First.Next /= Position.Node then
                return False;
-            end if;
-
-            if L.Last.Prev /= Position.Node then
+            elsif L.Last.Prev /= Position.Node then
                return False;
             end if;
          end if;
@@ -2134,11 +2133,12 @@ package body Ada.Containers.Doubly_Linked_Lists is
      (Stream : not null access Root_Stream_Type'Class;
       Item   : List)
    is
-      Node : Node_Access := Item.First;
+      Node : Node_Access;
 
    begin
       Count_Type'Base'Write (Stream, Item.Length);
 
+      Node := Item.First;
       while Node /= null loop
          Element_Type'Write (Stream, Node.Element);
          Node := Node.Next;
index 9d4eea1..cac6e9c 100644 (file)
@@ -2098,6 +2098,7 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
 
       declare
          L : List renames Position.Container.all;
+
       begin
          if L.Length = 0 then
             return False;
@@ -2119,15 +2120,11 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
             return False;
          end if;
 
-         if Position.Node.Prev = null
-           and then Position.Node /= L.First
-         then
+         if Position.Node.Prev = null and then Position.Node /= L.First then
             return False;
          end if;
 
-         if Position.Node.Next = null
-           and then Position.Node /= L.Last
-         then
+         if Position.Node.Next = null and then Position.Node /= L.Last then
             return False;
          end if;
 
index 5894a46..a0105d9 100755 (executable)
@@ -295,6 +295,7 @@ package body Aspects is
     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 2f60cb9..74eee35 100755 (executable)
@@ -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 @@ package Aspects is
       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 @@ package Aspects is
                              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 @@ package Aspects is
    -----------------------------------------
 
    --  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 @@ package Aspects is
      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 be60765..6151fc0 100644 (file)
@@ -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 @@ package Einfo is
 --       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 fb2be33..72feb25 100644 (file)
@@ -186,6 +186,7 @@ Implementation Defined Pragmas
 * 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 @@ consideration, the use of these pragmas should be minimized.
 * 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 @@ function is also considered pure from an optimization point of view, but the
 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 @@ A complete description of the AIs may be found in
 @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 b3d029f..328ddb6 100644 (file)
@@ -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 @@ begin
            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 6e1493a..d40f133 100644 (file)
@@ -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 @@ package body Sem_Attr is
          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 4d1794a..d73314d 100644 (file)
@@ -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 Opt;      use Opt;
 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 @@ package body Sem_Cat is
    ----------------------------------------------------
 
    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,18 +1740,16 @@ package body Sem_Cat is
       --    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
-
-      --    5. called from sem_res Resolve_Actuals
+      --    4. called from sem_res Resolve_Actuals
 
       if K = N_Attribute_Reference then
          E := Etype (Prefix (N));
@@ -1822,14 +1767,6 @@ package body Sem_Cat is
             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 a954ccd..ed7357a 100644 (file)
@@ -1442,14 +1442,43 @@ package body Sem_Ch12 is
                   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 f30e55d..072efa2 100644 (file)
@@ -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 @@ package body Sem_Dist is
       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 38a164a..0381bed 100644 (file)
@@ -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 @@ package Sem_Dist is
    --  (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 26289cb..b4df53f 100644 (file)
@@ -710,7 +710,7 @@ package body Sem_Prag is
 
       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 @@ package body Sem_Prag is
             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 @@ package body Sem_Prag is
       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 a8fc801..bb6945b 100644 (file)
@@ -6,7 +6,7 @@
  *                                                                          *
  *                         Asm Implementation File                          *
  *                                                                          *
- *            Copyright (C) 2011, Free Software Foundation, Inc.            *
+ *         Copyright (C) 2011-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- *
@@ -169,15 +169,23 @@ CR(".cfi_def_cfa " S(CFA_REG) ", 0")
 
 /* Register location blocks
    ------------------------
-   Rules to find registers of interest from the CFA. This should
-   comprise all the non-volatile registers relevant to the interrupted
-   context.  */
+   Rules to find registers of interest from the CFA. This should comprise
+   all the non-volatile registers relevant to the interrupted context.
+
+   Note that we include r1 in this set, unlike the libgcc unwinding
+   fallbacks.  This is useful for fallbacks to allow the use of r1 in CFI
+   expressions and the absence of rule for r1 gets compensated by using the
+   target CFA instead.  We don't need the expression facility here and
+   setup a fake CFA to allow very simple offset expressions, so having a
+   rule for r1 is the proper thing to do.  We for sure have observed
+   crashes in some cases without it.  */
 
 #define COMMON_CFI(REG) \
   ".cfi_offset " S(REGNO_##REG) "," S(REG_SET_##REG)
 
 #define CFI_COMMON_REGS \
 CR("# CFI for common registers\n") \
+TCR(COMMON_CFI(GR(1)))  \
 TCR(COMMON_CFI(GR(2)))  \
 TCR(COMMON_CFI(GR(3)))  \
 TCR(COMMON_CFI(GR(4)))  \
index a091047..aecebcd 100644 (file)
@@ -535,6 +535,7 @@ package Snames is
    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 @@ package Snames is
       Pragma_Pure_12,
       Pragma_Pure_Function,
       Pragma_Relative_Deadline,
+      Pragma_Remote_Access_Type,
       Pragma_Remote_Call_Interface,
       Pragma_Remote_Types,
       Pragma_Share_Generic,