From c8d3b4ff3f469a3553c0e5d27b5d25dd03bf34e0 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Tue, 12 May 2015 17:00:49 +0200 Subject: [PATCH] [multiple changes] 2015-05-12 Pierre-Marie de Rodat * sem_ch10.adb (Sem_Ch10.Analyze_Proper_Body): Generate SCOs for subunit in generic units. 2015-05-12 Robert Dewar * sem_elab.adb (Check_A_Call): Avoid checking internal call from Valid_Scalars 2015-05-12 Ed Schonberg * sem_ch6.adb (Process_Formals): An untagged incomplete type is legal in the profile of a null procedure. 2015-05-12 Ed Schonberg * sem_ch12.adb (Validate_Derived_Type_Instance): Handle properly the checks on a derived formal whose parent type is a previous formal that is not a derived type. 2015-05-12 Robert Dewar * aspects.ads, aspects.adb: Add entries for aspect Volatile_Full_Access * einfo.adb (Has_Volatile_Full_Access): New flag. (Has_Volatile_Full_Access): New flag. * einfo.ads (Has_Volatile_Full_Access): New flag. * par-prag.adb: Add dummy entry for Volatile_Full_Access. * sem_prag.adb (Analyze_Pragma, case Volatile_Full_Access): Implement new pragma. * snames.ads-tmpl: Add entries for pragma Volatile_Full_Access. 2015-05-12 Robert Dewar * targparm.ads: Minor reformatting. 2015-05-12 Robert Dewar * a-reatim.adb (Time_Of): Properly detect overflow when TS = 0.0. * a-reatim.ads: Minor reformatting. From-SVN: r223074 --- gcc/ada/ChangeLog | 41 +++++++++++++++ gcc/ada/a-reatim.adb | 22 ++++++++ gcc/ada/a-reatim.ads | 19 +++---- gcc/ada/aspects.adb | 2 + gcc/ada/aspects.ads | 7 ++- gcc/ada/einfo.adb | 13 ++++- gcc/ada/einfo.ads | 112 ++++++++++++++++++++++------------------ gcc/ada/par-prag.adb | 1 + gcc/ada/sem_ch10.adb | 12 ++++- gcc/ada/sem_ch12.adb | 11 ++++ gcc/ada/sem_ch6.adb | 14 +++-- gcc/ada/sem_elab.adb | 14 ++++- gcc/ada/sem_prag.adb | 92 ++++++++++++++++++++++++--------- gcc/ada/snames.ads-tmpl | 2 + gcc/ada/targparm.ads | 6 +-- 15 files changed, 273 insertions(+), 95 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index a9666ffddd45..e189279b3c21 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,44 @@ +2015-05-12 Pierre-Marie de Rodat + + * sem_ch10.adb (Sem_Ch10.Analyze_Proper_Body): Generate SCOs + for subunit in generic units. + +2015-05-12 Robert Dewar + + * sem_elab.adb (Check_A_Call): Avoid checking internal call + from Valid_Scalars + +2015-05-12 Ed Schonberg + + * sem_ch6.adb (Process_Formals): An untagged incomplete type + is legal in the profile of a null procedure. + +2015-05-12 Ed Schonberg + + * sem_ch12.adb (Validate_Derived_Type_Instance): Handle properly + the checks on a derived formal whose parent type is a previous + formal that is not a derived type. + +2015-05-12 Robert Dewar + + * aspects.ads, aspects.adb: Add entries for aspect Volatile_Full_Access + * einfo.adb (Has_Volatile_Full_Access): New flag. + (Has_Volatile_Full_Access): New flag. + * einfo.ads (Has_Volatile_Full_Access): New flag. + * par-prag.adb: Add dummy entry for Volatile_Full_Access. + * sem_prag.adb (Analyze_Pragma, case Volatile_Full_Access): + Implement new pragma. + * snames.ads-tmpl: Add entries for pragma Volatile_Full_Access. + +2015-05-12 Robert Dewar + + * targparm.ads: Minor reformatting. + +2015-05-12 Robert Dewar + + * a-reatim.adb (Time_Of): Properly detect overflow when TS = 0.0. + * a-reatim.ads: Minor reformatting. + 2015-05-12 Hristian Kirtchev * einfo.ads: Update the documentation of flags diff --git a/gcc/ada/a-reatim.adb b/gcc/ada/a-reatim.adb index 52aa9f3a372d..c313d5014271 100644 --- a/gcc/ada/a-reatim.adb +++ b/gcc/ada/a-reatim.adb @@ -228,6 +228,28 @@ package body Ada.Real_Time is function Time_Of (SC : Seconds_Count; TS : Time_Span) return Time is begin + -- Simple case first, TS = 0.0, we need to make sure SC is in range + + if TS = 0.0 then + if SC >= Seconds_Count (Duration (Time_Span_First) + Duration'(0.5)) + and then + SC <= Seconds_Count (Duration (Time_Span_Last) - Duration'(0.5)) + then + -- Don't need any further checks after that manual check + + declare + pragma Suppress (All_Checks); + begin + return Time (SC); + end; + + -- Here we have a Seconds_Count value that is out of range + + else + raise Constraint_Error; + end if; + end if; + -- We want to return Time (SC) + TS. To avoid spurious overflows in -- the intermediate result Time (SC) we take advantage of the different -- signs in SC and TS (when that is the case). diff --git a/gcc/ada/a-reatim.ads b/gcc/ada/a-reatim.ads index 8558d460a58d..4fbe7be54cff 100644 --- a/gcc/ada/a-reatim.ads +++ b/gcc/ada/a-reatim.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -91,18 +91,23 @@ package Ada.Real_Time is pragma Ada_05 (Minutes); type Seconds_Count is new Long_Long_Integer; - -- Seconds_Count needs 64 bits, since Time has the full range of + -- Seconds_Count needs 64 bits, since the type Time has the full range of -- Duration. The delta of Duration is 10 ** (-9), so the maximum number of -- seconds is 2**63/10**9 = 8*10**9 which does not quite fit in 32 bits. -- However, rather than make this explicitly 64-bits we derive from - -- Long_Long_Integer. In normal usage this will have the same effect. - -- But in the case of CodePeer with a target configuration file with a - -- maximum integer size of 32, it allows analysis of this unit. + -- Long_Long_Integer. In normal usage this will have the same effect. But + -- in the case of CodePeer with a target configuration file with a maximum + -- integer size of 32, it allows analysis of this unit. procedure Split (T : Time; SC : out Seconds_Count; TS : out Time_Span); function Time_Of (SC : Seconds_Count; TS : Time_Span) return Time; private + -- Time and Time_Span are represented in 64-bit Duration value in + -- nanoseconds. For example, 1 second and 1 nanosecond is represented + -- as the stored integer 1_000_000_001. This is for the 64-bit Duration + -- case, not clear if this also is used for 32-bit Duration values. + type Time is new Duration; Time_First : constant Time := Time'First; @@ -122,10 +127,6 @@ private Tick : constant Time_Span := Time_Span (System.Task_Primitives.Operations.RT_Resolution); - -- Time and Time_Span are represented in 64-bit Duration value in - -- nanoseconds. For example, 1 second and 1 nanosecond is represented - -- as the stored integer 1_000_000_001. - pragma Import (Intrinsic, "<"); pragma Import (Intrinsic, "<="); pragma Import (Intrinsic, ">"); diff --git a/gcc/ada/aspects.adb b/gcc/ada/aspects.adb index bef432f67ff8..976b89d7ec4a 100644 --- a/gcc/ada/aspects.adb +++ b/gcc/ada/aspects.adb @@ -55,6 +55,7 @@ package body Aspects is Aspect_Unchecked_Union => True, Aspect_Variable_Indexing => True, Aspect_Volatile => True, + Aspect_Volatile_Full_Access => True, others => False); -- The following array indicates type aspects that are inherited and apply @@ -606,6 +607,7 @@ package body Aspects is Aspect_Value_Size => Aspect_Value_Size, Aspect_Volatile => Aspect_Volatile, Aspect_Volatile_Components => Aspect_Volatile_Components, + Aspect_Volatile_Full_Access => Aspect_Volatile_Full_Access, Aspect_Warnings => Aspect_Warnings, Aspect_Write => Aspect_Write); diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads index 049efae87f10..41fa96100dc8 100644 --- a/gcc/ada/aspects.ads +++ b/gcc/ada/aspects.ads @@ -201,7 +201,8 @@ package Aspects is Aspect_Unreferenced, -- GNAT Aspect_Unreferenced_Objects, -- GNAT Aspect_Volatile, - Aspect_Volatile_Components); + Aspect_Volatile_Components, + Aspect_Volatile_Full_Access); -- GNAT subtype Aspect_Id_Exclude_No_Aspect is Aspect_Id range Aspect_Id'Succ (No_Aspect) .. Aspect_Id'Last; @@ -503,6 +504,7 @@ package Aspects is Aspect_Variable_Indexing => Name_Variable_Indexing, Aspect_Volatile => Name_Volatile, Aspect_Volatile_Components => Name_Volatile_Components, + Aspect_Volatile_Full_Access => Name_Volatile_Full_Access, Aspect_Warnings => Name_Warnings, Aspect_Write => Name_Write); @@ -737,7 +739,8 @@ package Aspects is Aspect_Storage_Size => Rep_Aspect, Aspect_Value_Size => Rep_Aspect, Aspect_Volatile => Rep_Aspect, - Aspect_Volatile_Components => Rep_Aspect); + Aspect_Volatile_Components => Rep_Aspect, + Aspect_Volatile_Full_Access => Rep_Aspect); ------------------------------------------------ -- Handling of Aspect Specifications on Stubs -- diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index f364960fe0fd..af85c2b10639 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -591,8 +591,8 @@ package body Einfo is -- Has_Nested_Subprogram Flag282 -- Is_Uplevel_Referenced_Entity Flag283 -- Is_Unimplemented Flag284 + -- Has_Volatile_Full_Access Flag285 - -- (unused) Flag285 -- (unused) Flag286 -- (unused) Flag287 -- (unused) Flag288 @@ -1849,6 +1849,11 @@ package body Einfo is return Flag87 (Implementation_Base_Type (Id)); end Has_Volatile_Components; + function Has_Volatile_Full_Access (Id : E) return B is + begin + return Flag285 (Id); + end Has_Volatile_Full_Access; + function Has_Xref_Entry (Id : E) return B is begin return Flag182 (Id); @@ -4730,6 +4735,11 @@ package body Einfo is Set_Flag87 (Id, V); end Set_Has_Volatile_Components; + procedure Set_Has_Volatile_Full_Access (Id : E; V : B := True) is + begin + Set_Flag285 (Id, V); + end Set_Has_Volatile_Full_Access; + procedure Set_Has_Xref_Entry (Id : E; V : B := True) is begin Set_Flag182 (Id, V); @@ -8695,6 +8705,7 @@ package body Einfo is W ("Has_Uplevel_Reference", Flag215 (Id)); W ("Has_Visible_Refinement", Flag263 (Id)); W ("Has_Volatile_Components", Flag87 (Id)); + W ("Has_Volatile_Full_Access", Flag285 (Id)); W ("Has_Xref_Entry", Flag182 (Id)); W ("In_Package_Body", Flag48 (Id)); W ("In_Private_Part", Flag45 (Id)); diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 7a068f2e2a00..bf21f76015fc 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -2046,6 +2046,12 @@ package Einfo is -- type the pragma will be chained to the rep item chain of the first -- subtype in the usual manner. +-- Has_Volatile_Full_Access (Flag285) +-- Defined in all type entities, and also in constants, components and +-- variables. Set if a pragma Volatile_Full_Access applies to the entity. +-- In the case of private and incomplete types, this flag is set in +-- both the partial view and the full view. + -- Has_Xref_Entry (Flag182) -- Defined in all entities. Set if an entity has an entry in the Xref -- information generated in ali files. This is true for all source @@ -5412,6 +5418,7 @@ package Einfo is -- Has_Task (Flag30) (base type only) -- Has_Unchecked_Union (Flag123) (base type only) -- Has_Volatile_Components (Flag87) (base type only) + -- Has_Volatile_Full_Access (Flag285) -- In_Use (Flag8) -- Is_Abstract_Type (Flag146) -- Is_Asynchronous (Flag81) @@ -5423,10 +5430,10 @@ package Einfo is -- Is_Frozen (Flag4) -- Is_Generic_Actual_Type (Flag94) -- Is_Independent (Flag268) - -- Is_RACW_Stub_Type (Flag244) -- Is_Non_Static_Subtype (Flag109) -- Is_Packed (Flag51) (base type only) -- Is_Private_Composite (Flag107) + -- Is_RACW_Stub_Type (Flag244) -- Is_Unsigned_Type (Flag144) -- Is_Volatile (Flag16) -- Itype_Printed (Flag202) (itypes only) @@ -5595,12 +5602,13 @@ package Einfo is -- Related_Type (Node27) -- Has_Biased_Representation (Flag139) -- Has_Per_Object_Constraint (Flag154) + -- Has_Volatile_Full_Access (Flag285) -- Is_Atomic (Flag85) -- Is_Independent (Flag268) + -- Is_Return_Object (Flag209) -- Is_Tag (Flag78) -- Is_Volatile (Flag16) -- Treat_As_Volatile (Flag41) - -- Is_Return_Object (Flag209) -- Next_Component (synth) -- Next_Component_Or_Discriminant (synth) @@ -5633,6 +5641,7 @@ package Einfo is -- Has_Size_Clause (Flag29) -- Has_Thunks (Flag228) (constants only) -- Has_Volatile_Components (Flag87) + -- Has_Volatile_Full_Access (Flag285) -- Is_Atomic (Flag85) -- Is_Eliminated (Flag124) -- Is_Independent (Flag268) @@ -5641,9 +5650,9 @@ package Einfo is -- Is_True_Constant (Flag163) -- Is_Uplevel_Referenced_Entity (Flag283) -- Is_Volatile (Flag16) - -- Stores_Attribute_Old_Prefix (Flag270) (constants only) -- Optimize_Alignment_Space (Flag241) (constants only) -- Optimize_Alignment_Time (Flag242) (constants only) + -- Stores_Attribute_Old_Prefix (Flag270) (constants only) -- Treat_As_Volatile (Flag41) -- Address_Clause (synth) -- Alignment_Clause (synth) @@ -6364,16 +6373,17 @@ package Einfo is -- Has_Initial_Value (Flag219) -- Has_Size_Clause (Flag29) -- Has_Volatile_Components (Flag87) + -- Has_Volatile_Full_Access (Flag285) -- Is_Atomic (Flag85) -- Is_Eliminated (Flag124) -- Is_Independent (Flag268) -- Is_Processed_Transient (Flag252) + -- Is_Return_Object (Flag209) -- Is_Safe_To_Reevaluate (Flag249) -- Is_Shared_Passive (Flag60) -- Is_True_Constant (Flag163) - -- Is_Volatile (Flag16) - -- Is_Return_Object (Flag209) -- Is_Uplevel_Referenced_Entity (Flag283) + -- Is_Volatile (Flag16) -- OK_To_Rename (Flag247) -- Optimize_Alignment_Space (Flag241) -- Optimize_Alignment_Time (Flag242) @@ -6630,12 +6640,11 @@ package Einfo is function Associated_Node_For_Itype (Id : E) return N; function Associated_Storage_Pool (Id : E) return E; function Barrier_Function (Id : E) return N; + function BIP_Initialization_Call (Id : E) return N; function Block_Node (Id : E) return N; function Body_Entity (Id : E) return E; function Body_Needed_For_SAL (Id : E) return B; function Body_References (Id : E) return L; - function BIP_Initialization_Call (Id : E) return N; - function CR_Discriminant (Id : E) return E; function C_Pass_By_Copy (Id : E) return B; function Can_Never_Be_Null (Id : E) return B; function Can_Use_Internal_Rep (Id : E) return B; @@ -6655,12 +6664,9 @@ package Einfo is function Corresponding_Protected_Entry (Id : E) return E; function Corresponding_Record_Type (Id : E) return E; function Corresponding_Remote_Type (Id : E) return E; + function CR_Discriminant (Id : E) return E; function Current_Use_Clause (Id : E) return E; function Current_Value (Id : E) return N; - function DTC_Entity (Id : E) return E; - function DT_Entry_Count (Id : E) return U; - function DT_Offset_To_Top_Func (Id : E) return E; - function DT_Position (Id : E) return U; function Debug_Info_Off (Id : E) return B; function Debug_Renaming_Link (Id : E) return E; function Default_Aspect_Component_Value (Id : E) return N; @@ -6685,6 +6691,10 @@ package Einfo is function Discriminant_Default_Value (Id : E) return N; function Discriminant_Number (Id : E) return U; function Dispatch_Table_Wrappers (Id : E) return L; + function DT_Entry_Count (Id : E) return U; + function DT_Offset_To_Top_Func (Id : E) return E; + function DT_Position (Id : E) return U; + function DTC_Entity (Id : E) return E; function Elaborate_Body_Desirable (Id : E) return B; function Elaboration_Entity (Id : E) return E; function Elaboration_Entity_Required (Id : E) return B; @@ -6815,6 +6825,7 @@ package Einfo is function Has_Uplevel_Reference (Id : E) return B; function Has_Visible_Refinement (Id : E) return B; function Has_Volatile_Components (Id : E) return B; + function Has_Volatile_Full_Access (Id : E) return B; function Has_Xref_Entry (Id : E) return B; function Hiding_Loop_Variable (Id : E) return E; function Homonym (Id : E) return E; @@ -6836,7 +6847,6 @@ package Einfo is function Is_Asynchronous (Id : E) return B; function Is_Atomic (Id : E) return B; function Is_Bit_Packed_Array (Id : E) return B; - function Is_CPP_Class (Id : E) return B; function Is_Called (Id : E) return B; function Is_Character_Type (Id : E) return B; function Is_Checked_Ghost_Entity (Id : E) return B; @@ -6844,12 +6854,13 @@ package Einfo is function Is_Class_Wide_Equivalent_Type (Id : E) return B; function Is_Compilation_Unit (Id : E) return B; function Is_Completely_Hidden (Id : E) return B; - function Is_Constr_Subt_For_UN_Aliased (Id : E) return B; function Is_Constr_Subt_For_U_Nominal (Id : E) return B; + function Is_Constr_Subt_For_UN_Aliased (Id : E) return B; function Is_Constrained (Id : E) return B; function Is_Constructor (Id : E) return B; function Is_Controlled (Id : E) return B; function Is_Controlling_Formal (Id : E) return B; + function Is_CPP_Class (Id : E) return B; function Is_Default_Init_Cond_Procedure (Id : E) return B; function Is_Descendent_Of_Address (Id : E) return B; function Is_Discrim_SO_Function (Id : E) return B; @@ -6976,7 +6987,6 @@ package Einfo is function Original_Record_Component (Id : E) return E; function Overlays_Constant (Id : E) return B; function Overridden_Operation (Id : E) return E; - function PPC_Wrapper (Id : E) return E; function Package_Instantiation (Id : E) return N; function Packed_Array_Impl_Type (Id : E) return E; function Parent_Subtype (Id : E) return E; @@ -6984,6 +6994,7 @@ package Einfo is function Partial_View_Has_Unknown_Discr (Id : E) return B; function Pending_Access_Types (Id : E) return L; function Postconditions_Proc (Id : E) return E; + function PPC_Wrapper (Id : E) return E; function Prival (Id : E) return E; function Prival_Link (Id : E) return E; function Private_Dependents (Id : E) return L; @@ -6991,7 +7002,6 @@ package Einfo is function Protected_Body_Subprogram (Id : E) return E; function Protected_Formal (Id : E) return E; function Protection_Object (Id : E) return E; - function RM_Size (Id : E) return U; function Reachable (Id : E) return B; function Referenced (Id : E) return B; function Referenced_As_LHS (Id : E) return B; @@ -7014,6 +7024,7 @@ package Einfo is function Returns_Limited_View (Id : E) return B; function Reverse_Bit_Order (Id : E) return B; function Reverse_Storage_Order (Id : E) return B; + function RM_Size (Id : E) return U; function Scalar_Range (Id : E) return N; function Scale_Value (Id : E) return U; function Scope_Depth_Value (Id : E) return U; @@ -7031,9 +7042,9 @@ package Einfo is function Spec_Entity (Id : E) return E; function SSO_Set_High_By_Default (Id : E) return B; function SSO_Set_Low_By_Default (Id : E) return B; + function Static_Discrete_Predicate (Id : E) return S; function Static_Elaboration_Desired (Id : E) return B; function Static_Initialization (Id : E) return N; - function Static_Discrete_Predicate (Id : E) return S; function Static_Real_Or_String_Predicate (Id : E) return N; function Status_Flag_Or_Transient_Decl (Id : E) return E; function Storage_Size_Variable (Id : E) return E; @@ -7282,12 +7293,11 @@ package Einfo is procedure Set_Associated_Node_For_Itype (Id : E; V : N); procedure Set_Associated_Storage_Pool (Id : E; V : E); procedure Set_Barrier_Function (Id : E; V : N); + procedure Set_BIP_Initialization_Call (Id : E; V : N); procedure Set_Block_Node (Id : E; V : N); procedure Set_Body_Entity (Id : E; V : E); procedure Set_Body_Needed_For_SAL (Id : E; V : B := True); procedure Set_Body_References (Id : E; V : L); - procedure Set_BIP_Initialization_Call (Id : E; V : N); - procedure Set_CR_Discriminant (Id : E; V : E); procedure Set_C_Pass_By_Copy (Id : E; V : B := True); procedure Set_Can_Never_Be_Null (Id : E; V : B := True); procedure Set_Can_Use_Internal_Rep (Id : E; V : B := True); @@ -7307,12 +7317,9 @@ package Einfo is procedure Set_Corresponding_Protected_Entry (Id : E; V : E); procedure Set_Corresponding_Record_Type (Id : E; V : E); procedure Set_Corresponding_Remote_Type (Id : E; V : E); + procedure Set_CR_Discriminant (Id : E; V : E); procedure Set_Current_Use_Clause (Id : E; V : E); procedure Set_Current_Value (Id : E; V : N); - procedure Set_DTC_Entity (Id : E; V : E); - procedure Set_DT_Entry_Count (Id : E; V : U); - procedure Set_DT_Offset_To_Top_Func (Id : E; V : E); - procedure Set_DT_Position (Id : E; V : U); procedure Set_Debug_Info_Off (Id : E; V : B := True); procedure Set_Debug_Renaming_Link (Id : E; V : E); procedure Set_Default_Aspect_Component_Value (Id : E; V : N); @@ -7337,6 +7344,10 @@ package Einfo is procedure Set_Discriminant_Default_Value (Id : E; V : N); procedure Set_Discriminant_Number (Id : E; V : U); procedure Set_Dispatch_Table_Wrappers (Id : E; V : L); + procedure Set_DT_Entry_Count (Id : E; V : U); + procedure Set_DT_Offset_To_Top_Func (Id : E; V : E); + procedure Set_DT_Position (Id : E; V : U); + procedure Set_DTC_Entity (Id : E; V : E); procedure Set_Elaborate_Body_Desirable (Id : E; V : B := True); procedure Set_Elaboration_Entity (Id : E; V : E); procedure Set_Elaboration_Entity_Required (Id : E; V : B := True); @@ -7465,6 +7476,7 @@ package Einfo is procedure Set_Has_Uplevel_Reference (Id : E; V : B := True); procedure Set_Has_Visible_Refinement (Id : E; V : B := True); procedure Set_Has_Volatile_Components (Id : E; V : B := True); + procedure Set_Has_Volatile_Full_Access (Id : E; V : B := True); procedure Set_Has_Xref_Entry (Id : E; V : B := True); procedure Set_Hiding_Loop_Variable (Id : E; V : E); procedure Set_Homonym (Id : E; V : E); @@ -7486,7 +7498,6 @@ package Einfo is procedure Set_Is_Asynchronous (Id : E; V : B := True); procedure Set_Is_Atomic (Id : E; V : B := True); procedure Set_Is_Bit_Packed_Array (Id : E; V : B := True); - procedure Set_Is_CPP_Class (Id : E; V : B := True); procedure Set_Is_Called (Id : E; V : B := True); procedure Set_Is_Character_Type (Id : E; V : B := True); procedure Set_Is_Checked_Ghost_Entity (Id : E; V : B := True); @@ -7495,12 +7506,13 @@ package Einfo is procedure Set_Is_Compilation_Unit (Id : E; V : B := True); procedure Set_Is_Completely_Hidden (Id : E; V : B := True); procedure Set_Is_Concurrent_Record_Type (Id : E; V : B := True); - procedure Set_Is_Constr_Subt_For_UN_Aliased (Id : E; V : B := True); procedure Set_Is_Constr_Subt_For_U_Nominal (Id : E; V : B := True); + procedure Set_Is_Constr_Subt_For_UN_Aliased (Id : E; V : B := True); procedure Set_Is_Constrained (Id : E; V : B := True); procedure Set_Is_Constructor (Id : E; V : B := True); procedure Set_Is_Controlled (Id : E; V : B := True); procedure Set_Is_Controlling_Formal (Id : E; V : B := True); + procedure Set_Is_CPP_Class (Id : E; V : B := True); procedure Set_Is_Default_Init_Cond_Procedure (Id : E; V : B := True); procedure Set_Is_Descendent_Of_Address (Id : E; V : B := True); procedure Set_Is_Discrim_SO_Function (Id : E; V : B := True); @@ -7632,7 +7644,6 @@ package Einfo is procedure Set_Original_Record_Component (Id : E; V : E); procedure Set_Overlays_Constant (Id : E; V : B := True); procedure Set_Overridden_Operation (Id : E; V : E); - procedure Set_PPC_Wrapper (Id : E; V : E); procedure Set_Package_Instantiation (Id : E; V : N); procedure Set_Packed_Array_Impl_Type (Id : E; V : E); procedure Set_Parent_Subtype (Id : E; V : E); @@ -7640,6 +7651,7 @@ package Einfo is procedure Set_Partial_View_Has_Unknown_Discr (Id : E; V : B := True); procedure Set_Pending_Access_Types (Id : E; V : L); procedure Set_Postconditions_Proc (Id : E; V : E); + procedure Set_PPC_Wrapper (Id : E; V : E); procedure Set_Prival (Id : E; V : E); procedure Set_Prival_Link (Id : E; V : E); procedure Set_Private_Dependents (Id : E; V : L); @@ -7647,7 +7659,6 @@ package Einfo is procedure Set_Protected_Body_Subprogram (Id : E; V : E); procedure Set_Protected_Formal (Id : E; V : E); procedure Set_Protection_Object (Id : E; V : E); - procedure Set_RM_Size (Id : E; V : U); procedure Set_Reachable (Id : E; V : B := True); procedure Set_Referenced (Id : E; V : B := True); procedure Set_Referenced_As_LHS (Id : E; V : B := True); @@ -7670,6 +7681,7 @@ package Einfo is procedure Set_Returns_Limited_View (Id : E; V : B := True); procedure Set_Reverse_Bit_Order (Id : E; V : B := True); procedure Set_Reverse_Storage_Order (Id : E; V : B := True); + procedure Set_RM_Size (Id : E; V : U); procedure Set_Scalar_Range (Id : E; V : N); procedure Set_Scale_Value (Id : E; V : U); procedure Set_Scope_Depth_Value (Id : E; V : U); @@ -7687,9 +7699,9 @@ package Einfo is procedure Set_Spec_Entity (Id : E; V : E); procedure Set_SSO_Set_High_By_Default (Id : E; V : B := True); procedure Set_SSO_Set_Low_By_Default (Id : E; V : B := True); + procedure Set_Static_Discrete_Predicate (Id : E; V : S); procedure Set_Static_Elaboration_Desired (Id : E; V : B); procedure Set_Static_Initialization (Id : E; V : N); - procedure Set_Static_Discrete_Predicate (Id : E; V : S); procedure Set_Static_Real_Or_String_Predicate (Id : E; V : N); procedure Set_Status_Flag_Or_Transient_Decl (Id : E; V : E); procedure Set_Storage_Size_Variable (Id : E; V : E); @@ -8055,12 +8067,11 @@ package Einfo is pragma Inline (Associated_Node_For_Itype); pragma Inline (Associated_Storage_Pool); pragma Inline (Barrier_Function); + pragma Inline (BIP_Initialization_Call); pragma Inline (Block_Node); pragma Inline (Body_Entity); pragma Inline (Body_Needed_For_SAL); pragma Inline (Body_References); - pragma Inline (BIP_Initialization_Call); - pragma Inline (CR_Discriminant); pragma Inline (C_Pass_By_Copy); pragma Inline (Can_Never_Be_Null); pragma Inline (Can_Use_Internal_Rep); @@ -8079,12 +8090,9 @@ package Einfo is pragma Inline (Corresponding_Protected_Entry); pragma Inline (Corresponding_Record_Type); pragma Inline (Corresponding_Remote_Type); + pragma Inline (CR_Discriminant); pragma Inline (Current_Use_Clause); pragma Inline (Current_Value); - pragma Inline (DTC_Entity); - pragma Inline (DT_Entry_Count); - pragma Inline (DT_Offset_To_Top_Func); - pragma Inline (DT_Position); pragma Inline (Debug_Info_Off); pragma Inline (Debug_Renaming_Link); pragma Inline (Default_Aspect_Component_Value); @@ -8109,6 +8117,10 @@ package Einfo is pragma Inline (Discriminant_Default_Value); pragma Inline (Discriminant_Number); pragma Inline (Dispatch_Table_Wrappers); + pragma Inline (DT_Entry_Count); + pragma Inline (DT_Offset_To_Top_Func); + pragma Inline (DT_Position); + pragma Inline (DTC_Entity); pragma Inline (Elaborate_Body_Desirable); pragma Inline (Elaboration_Entity); pragma Inline (Elaboration_Entity_Required); @@ -8236,6 +8248,7 @@ package Einfo is pragma Inline (Has_Uplevel_Reference); pragma Inline (Has_Visible_Refinement); pragma Inline (Has_Volatile_Components); + pragma Inline (Has_Volatile_Full_Access); pragma Inline (Has_Xref_Entry); pragma Inline (Hiding_Loop_Variable); pragma Inline (Homonym); @@ -8262,7 +8275,6 @@ package Einfo is pragma Inline (Is_Asynchronous); pragma Inline (Is_Atomic); pragma Inline (Is_Bit_Packed_Array); - pragma Inline (Is_CPP_Class); pragma Inline (Is_Called); pragma Inline (Is_Character_Type); pragma Inline (Is_Checked_Ghost_Entity); @@ -8275,12 +8287,13 @@ package Einfo is pragma Inline (Is_Concurrent_Body); pragma Inline (Is_Concurrent_Record_Type); pragma Inline (Is_Concurrent_Type); - pragma Inline (Is_Constr_Subt_For_UN_Aliased); pragma Inline (Is_Constr_Subt_For_U_Nominal); + pragma Inline (Is_Constr_Subt_For_UN_Aliased); pragma Inline (Is_Constrained); pragma Inline (Is_Constructor); pragma Inline (Is_Controlled); pragma Inline (Is_Controlling_Formal); + pragma Inline (Is_CPP_Class); pragma Inline (Is_Decimal_Fixed_Point_Type); pragma Inline (Is_Default_Init_Cond_Procedure); pragma Inline (Is_Descendent_Of_Address); @@ -8444,7 +8457,6 @@ package Einfo is pragma Inline (Original_Record_Component); pragma Inline (Overlays_Constant); pragma Inline (Overridden_Operation); - pragma Inline (PPC_Wrapper); pragma Inline (Package_Instantiation); pragma Inline (Packed_Array_Impl_Type); pragma Inline (Parameter_Mode); @@ -8453,6 +8465,7 @@ package Einfo is pragma Inline (Partial_View_Has_Unknown_Discr); pragma Inline (Pending_Access_Types); pragma Inline (Postconditions_Proc); + pragma Inline (PPC_Wrapper); pragma Inline (Prival); pragma Inline (Prival_Link); pragma Inline (Private_Dependents); @@ -8460,7 +8473,6 @@ package Einfo is pragma Inline (Protected_Body_Subprogram); pragma Inline (Protected_Formal); pragma Inline (Protection_Object); - pragma Inline (RM_Size); pragma Inline (Reachable); pragma Inline (Referenced); pragma Inline (Referenced_As_LHS); @@ -8483,6 +8495,7 @@ package Einfo is pragma Inline (Returns_Limited_View); pragma Inline (Reverse_Bit_Order); pragma Inline (Reverse_Storage_Order); + pragma Inline (RM_Size); pragma Inline (Scalar_Range); pragma Inline (Scale_Value); pragma Inline (Scope_Depth_Value); @@ -8500,9 +8513,9 @@ package Einfo is pragma Inline (Spec_Entity); pragma Inline (SSO_Set_High_By_Default); pragma Inline (SSO_Set_Low_By_Default); + pragma Inline (Static_Discrete_Predicate); pragma Inline (Static_Elaboration_Desired); pragma Inline (Static_Initialization); - pragma Inline (Static_Discrete_Predicate); pragma Inline (Static_Real_Or_String_Predicate); pragma Inline (Status_Flag_Or_Transient_Decl); pragma Inline (Storage_Size_Variable); @@ -8554,12 +8567,11 @@ package Einfo is pragma Inline (Set_Associated_Node_For_Itype); pragma Inline (Set_Associated_Storage_Pool); pragma Inline (Set_Barrier_Function); + pragma Inline (Set_BIP_Initialization_Call); pragma Inline (Set_Block_Node); pragma Inline (Set_Body_Entity); pragma Inline (Set_Body_Needed_For_SAL); pragma Inline (Set_Body_References); - pragma Inline (Set_BIP_Initialization_Call); - pragma Inline (Set_CR_Discriminant); pragma Inline (Set_C_Pass_By_Copy); pragma Inline (Set_Can_Never_Be_Null); pragma Inline (Set_Can_Use_Internal_Rep); @@ -8578,12 +8590,9 @@ package Einfo is pragma Inline (Set_Corresponding_Protected_Entry); pragma Inline (Set_Corresponding_Record_Type); pragma Inline (Set_Corresponding_Remote_Type); + pragma Inline (Set_CR_Discriminant); pragma Inline (Set_Current_Use_Clause); pragma Inline (Set_Current_Value); - pragma Inline (Set_DTC_Entity); - pragma Inline (Set_DT_Entry_Count); - pragma Inline (Set_DT_Offset_To_Top_Func); - pragma Inline (Set_DT_Position); pragma Inline (Set_Debug_Info_Off); pragma Inline (Set_Debug_Renaming_Link); pragma Inline (Set_Default_Aspect_Component_Value); @@ -8608,6 +8617,10 @@ package Einfo is pragma Inline (Set_Discriminant_Default_Value); pragma Inline (Set_Discriminant_Number); pragma Inline (Set_Dispatch_Table_Wrappers); + pragma Inline (Set_DT_Entry_Count); + pragma Inline (Set_DT_Offset_To_Top_Func); + pragma Inline (Set_DT_Position); + pragma Inline (Set_DTC_Entity); pragma Inline (Set_Elaborate_Body_Desirable); pragma Inline (Set_Elaboration_Entity); pragma Inline (Set_Elaboration_Entity_Required); @@ -8732,6 +8745,7 @@ package Einfo is pragma Inline (Set_Has_Unknown_Discriminants); pragma Inline (Set_Has_Visible_Refinement); pragma Inline (Set_Has_Volatile_Components); + pragma Inline (Set_Has_Volatile_Full_Access); pragma Inline (Set_Has_Xref_Entry); pragma Inline (Set_Hiding_Loop_Variable); pragma Inline (Set_Homonym); @@ -8752,7 +8766,6 @@ package Einfo is pragma Inline (Set_Is_Asynchronous); pragma Inline (Set_Is_Atomic); pragma Inline (Set_Is_Bit_Packed_Array); - pragma Inline (Set_Is_CPP_Class); pragma Inline (Set_Is_Called); pragma Inline (Set_Is_Character_Type); pragma Inline (Set_Is_Checked_Ghost_Entity); @@ -8761,12 +8774,13 @@ package Einfo is pragma Inline (Set_Is_Compilation_Unit); pragma Inline (Set_Is_Completely_Hidden); pragma Inline (Set_Is_Concurrent_Record_Type); - pragma Inline (Set_Is_Constr_Subt_For_UN_Aliased); pragma Inline (Set_Is_Constr_Subt_For_U_Nominal); + pragma Inline (Set_Is_Constr_Subt_For_UN_Aliased); pragma Inline (Set_Is_Constrained); pragma Inline (Set_Is_Constructor); pragma Inline (Set_Is_Controlled); pragma Inline (Set_Is_Controlling_Formal); + pragma Inline (Set_Is_CPP_Class); pragma Inline (Set_Is_Default_Init_Cond_Procedure); pragma Inline (Set_Is_Descendent_Of_Address); pragma Inline (Set_Is_Discrim_SO_Function); @@ -8898,7 +8912,6 @@ package Einfo is pragma Inline (Set_Original_Record_Component); pragma Inline (Set_Overlays_Constant); pragma Inline (Set_Overridden_Operation); - pragma Inline (Set_PPC_Wrapper); pragma Inline (Set_Package_Instantiation); pragma Inline (Set_Packed_Array_Impl_Type); pragma Inline (Set_Parent_Subtype); @@ -8906,6 +8919,7 @@ package Einfo is pragma Inline (Set_Partial_View_Has_Unknown_Discr); pragma Inline (Set_Pending_Access_Types); pragma Inline (Set_Postconditions_Proc); + pragma Inline (Set_PPC_Wrapper); pragma Inline (Set_Prival); pragma Inline (Set_Prival_Link); pragma Inline (Set_Private_Dependents); @@ -8913,7 +8927,6 @@ package Einfo is pragma Inline (Set_Protected_Body_Subprogram); pragma Inline (Set_Protected_Formal); pragma Inline (Set_Protection_Object); - pragma Inline (Set_RM_Size); pragma Inline (Set_Reachable); pragma Inline (Set_Referenced); pragma Inline (Set_Referenced_As_LHS); @@ -8936,6 +8949,7 @@ package Einfo is pragma Inline (Set_Returns_Limited_View); pragma Inline (Set_Reverse_Bit_Order); pragma Inline (Set_Reverse_Storage_Order); + pragma Inline (Set_RM_Size); pragma Inline (Set_Scalar_Range); pragma Inline (Set_Scale_Value); pragma Inline (Set_Scope_Depth_Value); @@ -8953,9 +8967,9 @@ package Einfo is pragma Inline (Set_Spec_Entity); pragma Inline (Set_SSO_Set_High_By_Default); pragma Inline (Set_SSO_Set_Low_By_Default); + pragma Inline (Set_Static_Discrete_Predicate); pragma Inline (Set_Static_Elaboration_Desired); pragma Inline (Set_Static_Initialization); - pragma Inline (Set_Static_Discrete_Predicate); pragma Inline (Set_Static_Real_Or_String_Predicate); pragma Inline (Set_Status_Flag_Or_Transient_Decl); pragma Inline (Set_Storage_Size_Variable); diff --git a/gcc/ada/par-prag.adb b/gcc/ada/par-prag.adb index ec8df4a98b7e..825929afa42c 100644 --- a/gcc/ada/par-prag.adb +++ b/gcc/ada/par-prag.adb @@ -1487,6 +1487,7 @@ begin Pragma_Use_VADS_Size | Pragma_Volatile | Pragma_Volatile_Components | + Pragma_Volatile_Full_Access | Pragma_Warning_As_Error | Pragma_Weak_External | Pragma_Validity_Checks => diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index 63d2cb75542a..97933bbda368 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -1713,6 +1713,16 @@ package body Sem_Ch10 is return; end if; + -- Collect SCO information for loaded subunit if we are in the + -- extended main unit. + + if Generate_SCO + and then In_Extended_Main_Source_Unit + (Cunit_Entity (Current_Sem_Unit)) + then + SCO_Record_Raw (Get_Cunit_Unit_Number (Library_Unit (N))); + end if; + Analyze_Subunit (Library_Unit (N)); -- Otherwise we must load the subunit and link to it @@ -1873,7 +1883,7 @@ package body Sem_Ch10 is Version_Update (Cunit (Main_Unit), Comp_Unit); -- Collect SCO information for loaded subunit if we are in - -- the main unit. + -- the extended main unit. if Generate_SCO and then diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index cac9db9cbf37..fca3856fca6e 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -11698,6 +11698,14 @@ package body Sem_Ch12 is Get_Instance_Of (Base_Type (Get_Instance_Of (A_Gen_T))); end if; + -- Check whether parent is a previous formal of the current generic + + elsif Is_Derived_Type (A_Gen_T) + and then Is_Generic_Type (Etype (A_Gen_T)) + and then Scope (A_Gen_T) = Scope (Etype (A_Gen_T)) + then + Ancestor := Get_Instance_Of (First_Subtype (Etype (A_Gen_T))); + -- An unusual case: the actual is a type declared in a parent unit, -- but is not a formal type so there is no instance_of for it. -- Retrieve it by analyzing the record extension. @@ -11733,6 +11741,9 @@ package body Sem_Ch12 is Actual, Ancestor); end if; + -- Finally verify that the (instance of) the ancestor is an ancestor + -- of the actual. + elsif not Is_Ancestor (Base_Type (Ancestor), Act_T) then Error_Msg_NE ("expect type derived from & in instantiation", diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 42fb1ddd2f2f..001365b712f7 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -9882,6 +9882,7 @@ package body Sem_Ch6 is (T : List_Id; Related_Nod : Node_Id) is + Context : constant Node_Id := Parent (Parent (T)); Param_Spec : Node_Id; Formal : Entity_Id; Formal_Type : Entity_Id; @@ -10027,6 +10028,8 @@ package body Sem_Ch6 is -- Incomplete formal untagged types are not allowed in -- subprogram bodies (but are legal in their declarations). + -- This excludes bodies created for null procedures, which + -- are basic declarations. if Is_Generic_Type (Formal_Type) and then not Is_Tagged_Type (Formal_Type) @@ -10042,13 +10045,14 @@ package body Sem_Ch6 is then null; - elsif Nkind_In (Parent (Parent (T)), N_Accept_Statement, - N_Accept_Alternative, - N_Entry_Body, - N_Subprogram_Body) + elsif Nkind_In (Context, N_Accept_Statement, + N_Accept_Alternative, + N_Entry_Body) + or else (Nkind (Context) = N_Subprogram_Body + and then Comes_From_Source (Context)) then Error_Msg_NE - ("invalid use of untagged incomplete type&", + ("invalid use of untagged incomplete type &", Ptype, Formal_Type); end if; diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb index 227469a1c27f..9e514c17411f 100644 --- a/gcc/ada/sem_elab.adb +++ b/gcc/ada/sem_elab.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1997-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1997-2015, 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- -- @@ -619,6 +619,18 @@ package body Sem_Elab is return; end if; + -- If this is a rewrite of a Valid_Scalars attribute, then nothing to + -- check, we don't mind in this case if the call occurs before the body + -- since this is all generated code. + + if Nkind (Original_Node (N)) = N_Attribute_Reference + and then Attribute_Name (Original_Node (N)) = Name_Valid_Scalars + then + return; + end if; + + -- Proceed with check + Ent := E; -- For a variable reference, just set Body_Acts_As_Spec to False diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 758aed07a72f..8e3cd4c9ecd7 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -3058,9 +3058,9 @@ package body Sem_Prag is -- Issue fatal error message for misplaced pragma procedure Process_Atomic_Independent_Shared_Volatile; - -- Common processing for pragmas Atomic, Independent, Shared, Volatile. - -- Note that Shared is an obsolete Ada 83 pragma and treated as being - -- identical in effect to pragma Atomic. + -- Common processing for pragmas Atomic, Independent, Shared, Volatile, + -- Volatile_Full_Access. Note that Shared is an obsolete Ada 83 pragma + -- and treated as being identical in effect to pragma Atomic. procedure Process_Compile_Time_Warning_Or_Error; -- Common processing for Compile_Time_Error and Compile_Time_Warning @@ -5822,24 +5822,28 @@ package body Sem_Prag is K : Node_Kind; Utyp : Entity_Id; - procedure Set_Atomic (E : Entity_Id); - -- Set given type as atomic, and if no explicit alignment was given, - -- set alignment to unknown, since back end knows what the alignment - -- requirements are for atomic arrays. Note: this step is necessary - -- for derived types. + procedure Set_Atomic_Full (E : Entity_Id); + -- Set given type as Is_Atomic or Has_Volatile_Full_Access. Also, if + -- no explicit alignment was given, set alignment to unknown, since + -- back end knows what the alignment requirements are for atomic and + -- full access arrays. Note: this is necessary for derived types. - ---------------- - -- Set_Atomic -- - ---------------- + --------------------- + -- Set_Atomic_Full -- + --------------------- - procedure Set_Atomic (E : Entity_Id) is + procedure Set_Atomic_Full (E : Entity_Id) is begin - Set_Is_Atomic (E); + if Prag_Id = Pragma_Volatile_Full_Access then + Set_Has_Volatile_Full_Access (E); + else + Set_Is_Atomic (E); + end if; if not Has_Alignment_Clause (E) then Set_Alignment (E, Uint_0); end if; - end Set_Atomic; + end Set_Atomic_Full; -- Start of processing for Process_Atomic_Independent_Shared_Volatile @@ -5874,13 +5878,18 @@ package body Sem_Prag is Check_First_Subtype (Arg1); end if; - if Prag_Id = Pragma_Atomic or else Prag_Id = Pragma_Shared then - Set_Atomic (E); - Set_Atomic (Underlying_Type (E)); - Set_Atomic (Base_Type (E)); + if Prag_Id = Pragma_Atomic + or else + Prag_Id = Pragma_Shared + or else + Prag_Id = Pragma_Volatile_Full_Access + then + Set_Atomic_Full (E); + Set_Atomic_Full (Underlying_Type (E)); + Set_Atomic_Full (Base_Type (E)); end if; - -- Atomic/Shared imply both Independent and Volatile + -- Atomic/Shared/Volatile_Full_Access imply Independent if Prag_Id /= Pragma_Volatile then Set_Is_Independent (E); @@ -5896,6 +5905,11 @@ package body Sem_Prag is -- currently private, it also belongs on the underlying type. if Prag_Id /= Pragma_Independent then + if Prag_Id = Pragma_Volatile_Full_Access then + Set_Has_Volatile_Full_Access (Base_Type (E)); + Set_Has_Volatile_Full_Access (Underlying_Type (E)); + end if; + Set_Is_Volatile (Base_Type (E)); Set_Is_Volatile (Underlying_Type (E)); @@ -5911,8 +5925,17 @@ package body Sem_Prag is return; end if; - if Prag_Id = Pragma_Atomic or else Prag_Id = Pragma_Shared then - Set_Is_Atomic (E); + if Prag_Id = Pragma_Atomic + or else + Prag_Id = Pragma_Shared + or else + Prag_Id = Pragma_Volatile_Full_Access + then + if Prag_Id = Pragma_Volatile_Full_Access then + Set_Has_Volatile_Full_Access (E); + else + Set_Is_Atomic (E); + end if; -- If the object declaration has an explicit initialization, a -- temporary may have to be created to hold the expression, to @@ -5939,6 +5962,9 @@ package body Sem_Prag is -- treated as atomic, thus incurring a potentially costly -- synchronization operation for every access. + -- For Volatile_Full_Access we can do this for elementary + -- types too, since there is no issue of atomic sync. + -- Of course it would be best if the back end could just adjust -- the alignment etc for the specific object, but that's not -- something we are capable of doing at this point. @@ -5946,14 +5972,21 @@ package body Sem_Prag is Utyp := Underlying_Type (Etype (E)); if Present (Utyp) - and then Is_Composite_Type (Utyp) + and then (Is_Composite_Type (Utyp) + or else Prag_Id = Pragma_Volatile_Full_Access) and then Sloc (E) > No_Location and then Sloc (Utyp) > No_Location and then Get_Source_File_Index (Sloc (E)) = Get_Source_File_Index (Sloc (Underlying_Type (Etype (E)))) then - Set_Is_Atomic (Underlying_Type (Etype (E))); + if Prag_Id = Pragma_Volatile_Full_Access then + Set_Has_Volatile_Full_Access + (Underlying_Type (Etype (E))); + else + Set_Is_Atomic + (Underlying_Type (Etype (E))); + end if; end if; end if; @@ -21220,7 +21253,17 @@ package body Sem_Prag is when Pragma_Volatile => Process_Atomic_Independent_Shared_Volatile; - ------------------------- + -------------------------- + -- Volatile_Full_Access -- + -------------------------- + + -- pragma Volatile_Full_Access (LOCAL_NAME); + + when Pragma_Volatile_Full_Access => + GNAT_Pragma; + Process_Atomic_Independent_Shared_Volatile; + + ------------------------- -- Volatile_Components -- ------------------------- @@ -26148,6 +26191,7 @@ package body Sem_Prag is Pragma_Validity_Checks => 0, Pragma_Volatile => 0, Pragma_Volatile_Components => 0, + Pragma_Volatile_Full_Access => 0, Pragma_Warning_As_Error => 0, Pragma_Warnings => 0, Pragma_Weak_External => 0, diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index 534d0d09d3b2..6dc7c00de9d7 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -632,6 +632,7 @@ package Snames is Name_Unreserve_All_Interrupts : constant Name_Id := N + $; -- GNAT Name_Volatile : constant Name_Id := N + $; Name_Volatile_Components : constant Name_Id := N + $; + Name_Volatile_Full_Access : constant Name_Id := N + $; -- GNAT Name_Weak_External : constant Name_Id := N + $; -- GNAT Last_Pragma_Name : constant Name_Id := N + $; @@ -1939,6 +1940,7 @@ package Snames is Pragma_Unreserve_All_Interrupts, Pragma_Volatile, Pragma_Volatile_Components, + Pragma_Volatile_Full_Access, Pragma_Weak_External, -- The following pragmas are on their own, out of order, because of the diff --git a/gcc/ada/targparm.ads b/gcc/ada/targparm.ads index efb6e028b2da..03dfb5153497 100644 --- a/gcc/ada/targparm.ads +++ b/gcc/ada/targparm.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1999-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1999-2015, 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- -- @@ -362,13 +362,13 @@ package Targparm is --------------------- -- By default, type Duration is a 64-bit fixed-point type with a delta - -- and small of 10**(-9) (i.e. it is a count in nanoseconds. This flag + -- and small of 10**(-9) (i.e. it is a count in nanoseconds). This flag -- allows that standard format to be modified. Duration_32_Bits_On_Target : Boolean := False; -- If True, then Duration is represented in 32 bits and the delta and -- small values are set to 20.0*(10**(-3)) (i.e. it is a count in units - -- of 20 milliseconds. + -- of 20 milliseconds). ------------------------------------ -- Back-End Code Generation Flags -- -- 2.39.2