[multiple changes]

2014-07-29  Ed Schonberg  <schonberg@adacore.com>

	* 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  <miranda@adacore.com>

	* 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  <schonberg@adacore.com>

	* par-ch3.adb (P_Type_Declaration): Create end label for
	limited record declaration, previously omitted.

2014-07-29  Robert Dewar  <dewar@adacore.com>

	* gnat_rm.texi: Complete list of implementation pragmas Add
	dummy sections for impl pragmas needing documentation.

From-SVN: r213195

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 7644f9ce21563e3c4ed48301fb524dc384e6be8b..618eaa90495321b42963288ca61dc079f5620c93 100644 (file)
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,14 @@
+2014-07-29  Ed Schonberg  <schonberg@adacore.com>
+
+       * 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  <dewar@adacore.com>
 
        * 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 819abcedd6c46ffedb0bc540aedc5930201860a6..a464aaa735c68b7b5848aaee042bf99b46c14dea 100644 (file)
--- 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 96506f88109b30c7e1093d7359e01e4682f1a78a..435f652de292470d0c2898274fddd18fdeec64aa 100644 (file)
--- 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 29a6e854f01f1aaa96693c218eb3e4a4560d9765..2152a0a9be6e27b6e32cf6415e84a0616522c901 100644 (file)
--- 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 658cb1e936ae486b4ca9076bfece61c91a501953..d06361fa009e272aa4cd139f1a0cbe1a0a07e32e 100644 (file)
--- 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 a5f5c804ad87130e78d35d78f7b26f378baba5aa..7e4dc8f2623c6b0d45ebcdadb118b61a1fc86441 100644 (file)
--- 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 41307a0e6243004dd9bb9d33572f0493062ee1a7..0da8b6ac0e990d0276109e38e94998861952a060 100644 (file)
--- 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 6b3a18df05a9fac101ecb8ba15337c68a746c4d8..cd535cf9ab55170c6b85d75b50b4a04fd629756c 100644 (file)
--- 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 c228740598277090f766b194bd18ff12ad5b44c1..bc2801026620fdce1faa27d487489fae454b8223 100644 (file)
--- 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;