diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 28 | ||||
| -rw-r--r-- | gcc/ada/a-cbdlli.adb | 8 | ||||
| -rw-r--r-- | gcc/ada/a-cdlili.adb | 42 | ||||
| -rw-r--r-- | gcc/ada/a-cidlli.adb | 9 | ||||
| -rwxr-xr-x | gcc/ada/aspects.adb | 1 | ||||
| -rwxr-xr-x | gcc/ada/aspects.ads | 6 | ||||
| -rw-r--r-- | gcc/ada/einfo.ads | 4 | ||||
| -rw-r--r-- | gcc/ada/gnat_rm.texi | 29 | ||||
| -rw-r--r-- | gcc/ada/par-prag.adb | 3 | ||||
| -rw-r--r-- | gcc/ada/sem_attr.adb | 28 | ||||
| -rw-r--r-- | gcc/ada/sem_cat.adb | 73 | ||||
| -rw-r--r-- | gcc/ada/sem_ch12.adb | 33 | ||||
| -rw-r--r-- | gcc/ada/sem_dist.adb | 46 | ||||
| -rw-r--r-- | gcc/ada/sem_dist.ads | 7 | ||||
| -rw-r--r-- | gcc/ada/sem_prag.adb | 36 | ||||
| -rw-r--r-- | gcc/ada/sigtramp-ppcvxw.c | 16 | ||||
| -rw-r--r-- | gcc/ada/snames.ads-tmpl | 2 |
17 files changed, 258 insertions, 113 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index bfc7f2e..f0b84ca 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -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 diff --git a/gcc/ada/a-cbdlli.adb b/gcc/ada/a-cbdlli.adb index 28c9622..df9bf22 100644 --- a/gcc/ada/a-cbdlli.adb +++ b/gcc/ada/a-cbdlli.adb @@ -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; diff --git a/gcc/ada/a-cdlili.adb b/gcc/ada/a-cdlili.adb index 1346e86..cfbcc36 100644 --- a/gcc/ada/a-cdlili.adb +++ b/gcc/ada/a-cdlili.adb @@ -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; diff --git a/gcc/ada/a-cidlli.adb b/gcc/ada/a-cidlli.adb index 9d4eea1..cac6e9c 100644 --- a/gcc/ada/a-cidlli.adb +++ b/gcc/ada/a-cidlli.adb @@ -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; diff --git a/gcc/ada/aspects.adb b/gcc/ada/aspects.adb index 5894a46..a0105d9 100755 --- a/gcc/ada/aspects.adb +++ b/gcc/ada/aspects.adb @@ -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, diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads index 2f60cb9..74eee35 100755 --- a/gcc/ada/aspects.ads +++ b/gcc/ada/aspects.ads @@ -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, diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index be60765..6151fc0 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -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 diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index fb2be33..72feb25 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -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 diff --git a/gcc/ada/par-prag.adb b/gcc/ada/par-prag.adb index b3d029f..328ddb6 100644 --- a/gcc/ada/par-prag.adb +++ b/gcc/ada/par-prag.adb @@ -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 | diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 6e1493a..d40f133 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -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"); diff --git a/gcc/ada/sem_cat.adb b/gcc/ada/sem_cat.adb index 4d1794a..d73314d 100644 --- a/gcc/ada/sem_cat.adb +++ b/gcc/ada/sem_cat.adb @@ -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 diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index a954ccd..ed7357a 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -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 => diff --git a/gcc/ada/sem_dist.adb b/gcc/ada/sem_dist.adb index f30e55d..072efa2 100644 --- a/gcc/ada/sem_dist.adb +++ b/gcc/ada/sem_dist.adb @@ -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 -- ------------------------------------ diff --git a/gcc/ada/sem_dist.ads b/gcc/ada/sem_dist.ads index 38a164a..0381bed 100644 --- a/gcc/ada/sem_dist.ads +++ b/gcc/ada/sem_dist.ads @@ -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 diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 26289cb..b4df53f 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -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, diff --git a/gcc/ada/sigtramp-ppcvxw.c b/gcc/ada/sigtramp-ppcvxw.c index a8fc801..bb6945b 100644 --- a/gcc/ada/sigtramp-ppcvxw.c +++ b/gcc/ada/sigtramp-ppcvxw.c @@ -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))) \ diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index a091047..aecebcd 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -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, |