From 552cedee79d2340ee82f74a8f6420d3781535e09 Mon Sep 17 00:00:00 2001 From: charlet Date: Tue, 29 Jul 2014 14:02:19 +0000 Subject: [PATCH] 2014-07-29 Ed Schonberg * exp_ch5.adb (Expand_N_Assignment_Statement): If the target type is a null-excluding access type, do not generate a constraint check if Suppress_Assignment_Checks is set on assignment node. * exp_ch9.adb (Build_Simple_Entry_Call): If actual is an out parameter of a null-excluding access type, there is access check on entry, so set Suppress_Assignment_Checks on generated statement that assigns actual to parameter block. * sinfo.ads: Document additional use of Suppress_Assignment_Checks. 2014-07-29 Javier Miranda * types.ads (Kind): Renamed as Rkind to avoid crashing ASIS. * exp_ch11.adb, tbuild.adb Update references to Types.Kind 2014-07-29 Ed Schonberg * par-ch3.adb (P_Type_Declaration): Create end label for limited record declaration, previously omitted. 2014-07-29 Robert Dewar * gnat_rm.texi: Complete list of implementation pragmas Add dummy sections for impl pragmas needing documentation. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@213195 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/ada/ChangeLog | 11 +++++++ gcc/ada/exp_ch11.adb | 2 +- gcc/ada/exp_ch5.adb | 1 + gcc/ada/exp_ch9.adb | 4 ++- gcc/ada/gnat_rm.texi | 39 ++++++++++++++++++++--- gcc/ada/par-ch3.adb | 4 +++ gcc/ada/sinfo.ads | 4 ++- gcc/ada/tbuild.adb | 6 ++-- gcc/ada/types.ads | 89 ++++++++++++++++++++++++++-------------------------- 9 files changed, 105 insertions(+), 55 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 7644f9c..618eaa9 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,14 @@ +2014-07-29 Ed Schonberg + + * exp_ch5.adb (Expand_N_Assignment_Statement): If the target type + is a null-excluding access type, do not generate a constraint + check if Suppress_Assignment_Checks is set on assignment node. + * exp_ch9.adb (Build_Simple_Entry_Call): If actual is an out + parameter of a null-excluding access type, there is access check + on entry, so set Suppress_Assignment_Checks on generated statement + that assigns actual to parameter block. + * sinfo.ads: Document additional use of Suppress_Assignment_Checks. + 2014-07-29 Robert Dewar * gnat_rm.texi: Change theta to @ in documentation of aspect diff --git a/gcc/ada/exp_ch11.adb b/gcc/ada/exp_ch11.adb index 819abce..a464aaa 100644 --- a/gcc/ada/exp_ch11.adb +++ b/gcc/ada/exp_ch11.adb @@ -2068,7 +2068,7 @@ package body Exp_Ch11 is function Get_RT_Exception_Entity (R : RT_Exception_Code) return Entity_Id is begin - case Kind (R) is + case Rkind (R) is when CE_Reason => return Standard_Constraint_Error; when PE_Reason => return Standard_Program_Error; when SE_Reason => return Standard_Storage_Error; diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 96506f8..435f652 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -2001,6 +2001,7 @@ package body Exp_Ch5 is if Is_Access_Type (Typ) and then Can_Never_Be_Null (Etype (Lhs)) and then not Can_Never_Be_Null (Etype (Rhs)) + and then not Suppress_Assignment_Checks (N) then Apply_Constraint_Check (Rhs, Etype (Lhs)); end if; diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 29a6e85..2152a0a 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -4755,7 +4755,8 @@ package body Exp_Ch9 is -- case of limited type. We cannot assign it unless the -- Assignment_OK flag is set first. An out formal of an -- access type must also be initialized from the actual, - -- as stated in RM 6.4.1 (13). + -- as stated in RM 6.4.1 (13), but no constraint is applied + -- before the call. if Ekind (Formal) /= E_Out_Parameter or else Is_Access_Type (Etype (Formal)) @@ -4767,6 +4768,7 @@ package body Exp_Ch9 is Make_Assignment_Statement (Loc, Name => N_Var, Expression => Relocate_Node (Actual))); + Set_Suppress_Assignment_Checks (Last (Stats)); end if; Append (N_Node, Decls); diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index 658cb1e..d06361f 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -112,7 +112,7 @@ Implementation Defined Pragmas * Pragma Assertion_Policy:: * Pragma Assume:: * Pragma Assume_No_Invalid_Values:: -* Pragma Ast_Entry:: +* Pragma AST_Entry:: * Pragma Async_Readers:: * Pragma Async_Writers:: * Pragma Attribute_Definition:: @@ -196,6 +196,7 @@ Implementation Defined Pragmas * Pragma Linker_Constructor:: * Pragma Linker_Destructor:: * Pragma Linker_Section:: +* Pragma Lock_Free:: * Pragma Long_Float:: * Pragma Loop_Invariant:: * Pragma Loop_Optimize:: @@ -234,6 +235,7 @@ Implementation Defined Pragmas * Pragma Provide_Shift_Operators:: * Pragma Psect_Object:: * Pragma Pure_Function:: +* Pragma Rational:: * Pragma Ravenscar:: * Pragma Refined_Depends:: * Pragma Refined_Global:: @@ -976,7 +978,7 @@ consideration, the use of these pragmas should be minimized. * Pragma Assertion_Policy:: * Pragma Assume:: * Pragma Assume_No_Invalid_Values:: -* Pragma Ast_Entry:: +* Pragma AST_Entry:: * Pragma Async_Readers:: * Pragma Async_Writers:: * Pragma Attribute_Definition:: @@ -1060,6 +1062,7 @@ consideration, the use of these pragmas should be minimized. * Pragma Linker_Constructor:: * Pragma Linker_Destructor:: * Pragma Linker_Section:: +* Pragma Lock_Free:: * Pragma Long_Float:: * Pragma Loop_Invariant:: * Pragma Loop_Optimize:: @@ -1098,6 +1101,7 @@ consideration, the use of these pragmas should be minimized. * Pragma Provide_Shift_Operators:: * Pragma Psect_Object:: * Pragma Pure_Function:: +* Pragma Rational:: * Pragma Ravenscar:: * Pragma Refined_Depends:: * Pragma Refined_Global:: @@ -1673,10 +1677,10 @@ section 7.1.2. For the description of this pragma, see SPARK 2014 Reference Manual, section 7.1.2. -@node Pragma Ast_Entry -@unnumberedsec Pragma Ast_Entry +@node Pragma AST_Entry +@unnumberedsec Pragma AST_Entry @cindex OpenVMS -@findex Ast_Entry +@findex AST_Entry @noindent Syntax: @smallexample @c ada @@ -4488,6 +4492,13 @@ package IO_Card is end IO_Card; @end smallexample +@node Pragma Lock_Free +@unnumberedsec Pragma Locl_Free +@findex Lock_Free +@noindent +Syntax: +PLEASE ADD DOCUMENTATION HERE??? + @node Pragma Long_Float @unnumberedsec Pragma Long_Float @cindex OpenVMS @@ -6089,6 +6100,24 @@ 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 Rational +@unnumberedsec Pragma Rational +@findex Rational +@noindent +Syntax: + +@smallexample @c ada +pragma Rational; +@end smallexample + +@noindent +This pragma is considered obsolescent, but is retained for +compatibility purposes. It is equivalent to: + +@smallexample @c ada +pragma Profile (Rational); +@end smallexample + @node Pragma Ravenscar @unnumberedsec Pragma Ravenscar @findex Pragma Ravenscar diff --git a/gcc/ada/par-ch3.adb b/gcc/ada/par-ch3.adb index a5f5c80..7e4dc8f 100644 --- a/gcc/ada/par-ch3.adb +++ b/gcc/ada/par-ch3.adb @@ -652,6 +652,10 @@ package body Ch3 is Typedef_Node := P_Record_Definition; Set_Limited_Present (Typedef_Node, True); + End_Labl := Make_Identifier (Token_Ptr, Chars (Ident_Node)); + Set_Comes_From_Source (End_Labl, False); + + Set_End_Label (Typedef_Node, End_Labl); -- Ada 2005 (AI-251): LIMITED INTERFACE diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 41307a0..0da8b6a 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -2052,7 +2052,9 @@ package Sinfo is -- and range checks in cases where the generated code knows that the -- value being assigned is in range and satisfies any predicate. Also -- can be set in N_Object_Declaration nodes, to similarly suppress any - -- checks on the initializing value. + -- checks on the initializing value. In assignment statements it also + -- suppresses access checks in the generated code for out- and in-out + -- parameters in entry calls. -- Suppress_Loop_Warnings (Flag17-Sem) -- Used in N_Loop_Statement node to indicate that warnings within the diff --git a/gcc/ada/tbuild.adb b/gcc/ada/tbuild.adb index 6b3a18d..cd535cf 100644 --- a/gcc/ada/tbuild.adb +++ b/gcc/ada/tbuild.adb @@ -434,7 +434,7 @@ package body Tbuild is Reason : RT_Exception_Code) return Node_Id is begin - pragma Assert (Kind (Reason) = CE_Reason); + pragma Assert (Rkind (Reason) = CE_Reason); return Make_Raise_Constraint_Error (Sloc, Condition => Condition, @@ -451,7 +451,7 @@ package body Tbuild is Reason : RT_Exception_Code) return Node_Id is begin - pragma Assert (Kind (Reason) = PE_Reason); + pragma Assert (Rkind (Reason) = PE_Reason); return Make_Raise_Program_Error (Sloc, Condition => Condition, @@ -468,7 +468,7 @@ package body Tbuild is Reason : RT_Exception_Code) return Node_Id is begin - pragma Assert (Kind (Reason) = SE_Reason); + pragma Assert (Rkind (Reason) = SE_Reason); return Make_Raise_Storage_Error (Sloc, Condition => Condition, diff --git a/gcc/ada/types.ads b/gcc/ada/types.ads index c228740..bc28010 100644 --- a/gcc/ada/types.ads +++ b/gcc/ada/types.ads @@ -855,17 +855,18 @@ package Types is CE_Length_Check_Failed, -- 07 CE_Null_Exception_Id, -- 08 CE_Null_Not_Allowed, -- 09 + CE_Overflow_Check_Failed, -- 10 CE_Partition_Check_Failed, -- 11 CE_Range_Check_Failed, -- 12 CE_Tag_Check_Failed, -- 13 - PE_Access_Before_Elaboration, -- 14 PE_Accessibility_Check_Failed, -- 15 PE_Address_Of_Intrinsic, -- 16 PE_Aliased_Parameters, -- 17 PE_All_Guards_Closed, -- 18 PE_Bad_Predicated_Generic_Type, -- 19 + PE_Current_Task_In_Entry_Body, -- 20 PE_Duplicated_Entry_Address, -- 21 PE_Explicit_Raise, -- 22 @@ -876,60 +877,60 @@ package Types is PE_Overlaid_Controlled_Object, -- 27 PE_Potentially_Blocking_Operation, -- 28 PE_Stubbed_Subprogram_Called, -- 29 + PE_Unchecked_Union_Restriction, -- 30 PE_Non_Transportable_Actual, -- 31 - SE_Empty_Storage_Pool, -- 32 SE_Explicit_Raise, -- 33 SE_Infinite_Recursion, -- 34 SE_Object_Too_Large, -- 35 - PE_Stream_Operation_Not_Allowed); -- 36 Last_Reason_Code : constant := 36; -- Last reason code type Reason_Kind is (CE_Reason, PE_Reason, SE_Reason); - - Kind : array (RT_Exception_Code range <>) of Reason_Kind := - (CE_Access_Check_Failed => CE_Reason, - CE_Access_Parameter_Is_Null => CE_Reason, - CE_Discriminant_Check_Failed => CE_Reason, - CE_Divide_By_Zero => CE_Reason, - CE_Explicit_Raise => CE_Reason, - CE_Index_Check_Failed => CE_Reason, - CE_Invalid_Data => CE_Reason, - CE_Length_Check_Failed => CE_Reason, - CE_Null_Exception_Id => CE_Reason, - CE_Null_Not_Allowed => CE_Reason, - CE_Overflow_Check_Failed => CE_Reason, - CE_Partition_Check_Failed => CE_Reason, - CE_Range_Check_Failed => CE_Reason, - CE_Tag_Check_Failed => CE_Reason, - - PE_Access_Before_Elaboration => PE_Reason, - PE_Accessibility_Check_Failed => PE_Reason, - PE_Address_Of_Intrinsic => PE_Reason, - PE_Aliased_Parameters => PE_Reason, - PE_All_Guards_Closed => PE_Reason, - PE_Bad_Predicated_Generic_Type => PE_Reason, - PE_Current_Task_In_Entry_Body => PE_Reason, - PE_Duplicated_Entry_Address => PE_Reason, - PE_Explicit_Raise => PE_Reason, - PE_Finalize_Raised_Exception => PE_Reason, - PE_Implicit_Return => PE_Reason, - PE_Misaligned_Address_Value => PE_Reason, - PE_Missing_Return => PE_Reason, - PE_Overlaid_Controlled_Object => PE_Reason, - PE_Potentially_Blocking_Operation => PE_Reason, - PE_Stubbed_Subprogram_Called => PE_Reason, - PE_Unchecked_Union_Restriction => PE_Reason, - PE_Non_Transportable_Actual => PE_Reason, - PE_Stream_Operation_Not_Allowed => PE_Reason, - - SE_Empty_Storage_Pool => SE_Reason, - SE_Explicit_Raise => SE_Reason, - SE_Infinite_Recursion => SE_Reason, - SE_Object_Too_Large => SE_Reason); + -- Categorization of reason codes by exception raised + + Rkind : array (RT_Exception_Code range <>) of Reason_Kind := + (CE_Access_Check_Failed => CE_Reason, + CE_Access_Parameter_Is_Null => CE_Reason, + CE_Discriminant_Check_Failed => CE_Reason, + CE_Divide_By_Zero => CE_Reason, + CE_Explicit_Raise => CE_Reason, + CE_Index_Check_Failed => CE_Reason, + CE_Invalid_Data => CE_Reason, + CE_Length_Check_Failed => CE_Reason, + CE_Null_Exception_Id => CE_Reason, + CE_Null_Not_Allowed => CE_Reason, + CE_Overflow_Check_Failed => CE_Reason, + CE_Partition_Check_Failed => CE_Reason, + CE_Range_Check_Failed => CE_Reason, + CE_Tag_Check_Failed => CE_Reason, + + PE_Access_Before_Elaboration => PE_Reason, + PE_Accessibility_Check_Failed => PE_Reason, + PE_Address_Of_Intrinsic => PE_Reason, + PE_Aliased_Parameters => PE_Reason, + PE_All_Guards_Closed => PE_Reason, + PE_Bad_Predicated_Generic_Type => PE_Reason, + PE_Current_Task_In_Entry_Body => PE_Reason, + PE_Duplicated_Entry_Address => PE_Reason, + PE_Explicit_Raise => PE_Reason, + PE_Finalize_Raised_Exception => PE_Reason, + PE_Implicit_Return => PE_Reason, + PE_Misaligned_Address_Value => PE_Reason, + PE_Missing_Return => PE_Reason, + PE_Overlaid_Controlled_Object => PE_Reason, + PE_Potentially_Blocking_Operation => PE_Reason, + PE_Stubbed_Subprogram_Called => PE_Reason, + PE_Unchecked_Union_Restriction => PE_Reason, + PE_Non_Transportable_Actual => PE_Reason, + PE_Stream_Operation_Not_Allowed => PE_Reason, + + SE_Empty_Storage_Pool => SE_Reason, + SE_Explicit_Raise => SE_Reason, + SE_Infinite_Recursion => SE_Reason, + SE_Object_Too_Large => SE_Reason); end Types; -- 2.7.4