a-cbmutr.adb: Minor reformatting

2011-08-05  Robert Dewar  <dewar@adacore.com>

	* a-cbmutr.adb: Minor reformatting
	(Allocate_Node): refactor node allocation algorithm

2011-08-05  Robert Dewar  <dewar@adacore.com>

	* opt.ads, opt.adb (Debug_Pragmas_Disabled): New switch.
	* sem_prag.adb (Analyze_Pragma, case Debug_Policy): Implement Disable
	mode.
	(Analyze_Pragma, case Check_Policy): Ditto.
	* sem_prag.ads (Check_Disabled): New function
	* snames.ads-tmpl: Add Name_Disable.

2011-08-05  Robert Dewar  <dewar@adacore.com>

	* gnat_rm.texi: Document implementation-defined policy DISABLE for
	pragmas Assertion_Policy, Check_Policy, Debug_Policy.

From-SVN: r177459

8 files changed, 249 insertions, 96 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index c37c1de..68f4414 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,22 @@
+2011-08-05  Robert Dewar  <dewar@adacore.com>
+
+	* a-cbmutr.adb: Minor reformatting
+	(Allocate_Node): refactor node allocation algorithm
+
+2011-08-05  Robert Dewar  <dewar@adacore.com>
+
+	* opt.ads, opt.adb (Debug_Pragmas_Disabled): New switch.
+	* sem_prag.adb (Analyze_Pragma, case Debug_Policy): Implement Disable
+	mode.
+	(Analyze_Pragma, case Check_Policy): Ditto.
+	* sem_prag.ads (Check_Disabled): New function
+	* snames.ads-tmpl: Add Name_Disable.
+
+2011-08-05  Robert Dewar  <dewar@adacore.com>
+
+	* gnat_rm.texi: Document implementation-defined policy DISABLE for
+	pragmas Assertion_Policy, Check_Policy, Debug_Policy.
+
 2011-08-05  Ed Schonberg  <schonberg@adacore.com>
 
 	* sem_prag.adb (Analyze_Pragma, case Inline): reject an Inline pragma
diff --git a/gcc/ada/a-cbmutr.adb b/gcc/ada/a-cbmutr.adb
index 1392a4f..b365d47 100644
--- a/gcc/ada/a-cbmutr.adb
+++ b/gcc/ada/a-cbmutr.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 2004-2011, Free Software Foundation, Inc.         --
+--             Copyright (C) 2011, 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- --
@@ -39,6 +39,11 @@ package body Ada.Containers.Bounded_Multiway_Trees is
    procedure Initialize_Root (Container : in out Tree);
 
    procedure Allocate_Node
+     (Container          : in out Tree;
+      Initialize_Element : not null access procedure (Index : Count_Type);
+      New_Node           : out Count_Type);
+
+   procedure Allocate_Node
      (Container : in out Tree;
       New_Item  : Element_Type;
       New_Node  : out Count_Type);
@@ -194,18 +199,20 @@ package body Ada.Containers.Bounded_Multiway_Trees is
    -------------------
 
    procedure Allocate_Node
-     (Container : in out Tree;
-      New_Item  : Element_Type;
-      New_Node  : out Count_Type)
+     (Container          : in out Tree;
+      Initialize_Element : not null access procedure (Index : Count_Type);
+      New_Node           : out Count_Type)
    is
    begin
       if Container.Free >= 0 then
          New_Node := Container.Free;
+         pragma Assert (New_Node in Container.Elements'Range);
 
          --  We always perform the assignment first, before we change container
          --  state, in order to defend against exceptions duration assignment.
 
-         Container.Elements (New_Node) := New_Item;
+         Initialize_Element (New_Node);
+
          Container.Free := Container.Nodes (New_Node).Next;
 
       else
@@ -216,12 +223,18 @@ package body Ada.Containers.Bounded_Multiway_Trees is
          --  the end of the array (Nodes'Last).
 
          New_Node := abs Container.Free;
+         pragma Assert (New_Node in Container.Elements'Range);
 
          --  As above, we perform this assignment first, before modifying any
          --  container state.
 
-         Container.Elements (New_Node) := New_Item;
+         Initialize_Element (New_Node);
+
          Container.Free := Container.Free - 1;
+
+         if abs Container.Free > Container.Capacity then
+            Container.Free := 0;
+         end if;
       end if;
 
       Initialize_Node (Container, New_Node);
@@ -229,59 +242,43 @@ package body Ada.Containers.Bounded_Multiway_Trees is
 
    procedure Allocate_Node
      (Container : in out Tree;
-      Stream    : not null access Root_Stream_Type'Class;
+      New_Item  : Element_Type;
       New_Node  : out Count_Type)
    is
-   begin
-      if Container.Free >= 0 then
-         New_Node := Container.Free;
-
-         --  We always perform the assignment first, before we change container
-         --  state, in order to defend against exceptions duration assignment.
+      procedure Initialize_Element (Index : Count_Type);
 
-         Element_Type'Read (Stream, Container.Elements (New_Node));
-         Container.Free := Container.Nodes (New_Node).Next;
-
-      else
-         --  A negative free store value means that the links of the nodes in
-         --  the free store have not been initialized. In this case, the nodes
-         --  are physically contiguous in the array, starting at the index that
-         --  is the absolute value of the Container.Free, and continuing until
-         --  the end of the array (Nodes'Last).
+      procedure Initialize_Element (Index : Count_Type) is
+      begin
+         Container.Elements (Index) := New_Item;
+      end Initialize_Element;
 
-         New_Node := abs Container.Free;
+   begin
+      Allocate_Node (Container, Initialize_Element'Access, New_Node);
+   end Allocate_Node;
 
-         --  As above, we perform this assignment first, before modifying any
-         --  container state.
+   procedure Allocate_Node
+     (Container : in out Tree;
+      Stream    : not null access Root_Stream_Type'Class;
+      New_Node  : out Count_Type)
+   is
+      procedure Initialize_Element (Index : Count_Type);
 
-         Element_Type'Read (Stream, Container.Elements (New_Node));
-         Container.Free := Container.Free - 1;
-      end if;
+      procedure Initialize_Element (Index : Count_Type) is
+      begin
+         Element_Type'Read (Stream, Container.Elements (Index));
+      end Initialize_Element;
 
-      Initialize_Node (Container, New_Node);
+   begin
+      Allocate_Node (Container, Initialize_Element'Access, New_Node);
    end Allocate_Node;
 
    procedure Allocate_Node
      (Container : in out Tree;
       New_Node  : out Count_Type)
    is
+      procedure Initialize_Element (Index : Count_Type) is null;
    begin
-      if Container.Free >= 0 then
-         New_Node := Container.Free;
-         Container.Free := Container.Nodes (New_Node).Next;
-
-      else
-         --  A negative free store value means that the links of the nodes in
-         --  the free store have not been initialized. In this case, the nodes
-         --  are physically contiguous in the array, starting at the index that
-         --  is the absolute value of the Container.Free, and continuing until
-         --  the end of the array (Nodes'Last).
-
-         New_Node := abs Container.Free;
-         Container.Free := Container.Free - 1;
-      end if;
-
-      Initialize_Node (Container, New_Node);
+      Allocate_Node (Container, Initialize_Element'Access, New_Node);
    end Allocate_Node;
 
    -------------------
@@ -405,7 +402,7 @@ package body Ada.Containers.Bounded_Multiway_Trees is
            with "Target capacity is less than Source count";
       end if;
 
-      Target.Clear;  -- checks busy bit
+      Target.Clear;  -- Checks busy bit
 
       if Source.Count = 0 then
          return;
@@ -647,7 +644,6 @@ package body Ada.Containers.Bounded_Multiway_Trees is
       if Parent.Container.Count = 0 then
          pragma Assert (Is_Root (Parent));
          pragma Assert (Child = Parent);
-
          return 0;
       end if;
 
@@ -823,8 +819,8 @@ package body Ada.Containers.Bounded_Multiway_Trees is
       --  the "normal" way: Container.Free points to the head of the list of
       --  free (inactive) nodes, and the value 0 means the free list is
       --  empty. Each node on the free list has been initialized to point to
-      --  the next free node (via its Next component), and the value -1 means
-      --  that this is the last free node.
+      --  the next free node (via its Next component), and the value 0 means
+      --  that this is the last node of the free list.
       --
       --  If Container.Free is negative, then the links on the free store have
       --  not been initialized. In this case the link values are implied: the
@@ -833,11 +829,11 @@ package body Ada.Containers.Bounded_Multiway_Trees is
       --  the array (Nodes'Last).
       --
       --  We prefer to lazy-init the free store (in fact, we would prefer to
-      --  not initialize it at all). The time when we need to actually
-      --  initialize the nodes in the free store is if the node that becomes
-      --  inactive is not at the end of the active list. The free store would
-      --  then be discontigous and so its nodes would need to be linked in the
-      --  traditional way.
+      --  not initialize it at all, because such initialization is an O(n)
+      --  operation). The time when we need to actually initialize the nodes in
+      --  the free store is when the node that becomes inactive is not at the
+      --  end of the active list. The free store would then be discontigous and
+      --  so its nodes would need to be linked in the traditional way.
       --
       --  It might be possible to perform an optimization here. Suppose that
       --  the free store can be represented as having two parts: one comprising
@@ -848,16 +844,17 @@ package body Ada.Containers.Bounded_Multiway_Trees is
       --  nodes become inactive. ???
 
       --  When an element is deleted from the list container, its node becomes
-      --  inactive, and so we set its Prev component to a negative value, to
-      --  indicate that it is now inactive. This provides a useful way to
-      --  detect a dangling cursor reference.
+      --  inactive, and so we set its Parent and Prev components to an
+      --  impossible value (the index of the node itself), to indicate that it
+      --  is now inactive. This provides a useful way to detect a dangling
+      --  cursor reference.
 
       N.Parent := X;  -- Node is deallocated (not on active list)
       N.Prev := X;
 
       if Container.Free >= 0 then
-         --  The free store has previously been initialized. All we need to
-         --  do here is link the newly-free'd node onto the free list.
+         --  The free store has previously been initialized. All we need to do
+         --  here is link the newly-free'd node onto the free list.
 
          N.Next := Container.Free;
          Container.Free := X;
@@ -867,7 +864,7 @@ package body Ada.Containers.Bounded_Multiway_Trees is
          --  inactive immediately precedes the start of the free store. All
          --  we need to do is move the start of the free store back by one.
 
-         N.Next := -1;  -- Not strictly necessary, but marginally safer
+         N.Next := X;  -- Not strictly necessary, but marginally safer
          Container.Free := Container.Free + 1;
 
       else
@@ -880,8 +877,8 @@ package body Ada.Containers.Bounded_Multiway_Trees is
          --  See the comments above for an optimization opportunity. If the
          --  next link for a node on the free store is negative, then this
          --  means the remaining nodes on the free store are physically
-         --  contiguous, starting as the absolute value of that index
-         --  value. ???
+         --  contiguous, starting at the absolute value of that index value.
+         --  ???
 
          Container.Free := abs Container.Free;
 
@@ -893,7 +890,7 @@ package body Ada.Containers.Bounded_Multiway_Trees is
                NN (J).Next := J + 1;
             end loop;
 
-            NN (Container.Capacity).Next := -1;
+            NN (Container.Capacity).Next := 0;
          end if;
 
          NN (X).Next := Container.Free;
@@ -1558,8 +1555,7 @@ package body Ada.Containers.Bounded_Multiway_Trees is
    begin
       --  This is a simple utility operation to insert a list of nodes
       --  (First..Last) as children of Parent. The Before node specifies where
-      --  the new children should be inserted relative to the existing
-      --  children.
+      --  the new children should be inserted relative to existing children.
 
       if First <= 0 then
          pragma Assert (Last <= 0);
@@ -2233,8 +2229,8 @@ package body Ada.Containers.Bounded_Multiway_Trees is
       CC : Children_Type renames NN (N.Parent).Children;
 
    begin
-      --  This is a utility operation to remove a subtree
-      --  node from its parent's list of children.
+      --  This is a utility operation to remove a subtree node from its
+      --  parent's list of children.
 
       if CC.First = Subtree then
          pragma Assert (N.Prev <= 0);
@@ -2356,11 +2352,11 @@ package body Ada.Containers.Bounded_Multiway_Trees is
    ---------------------
 
    procedure Splice_Children
-     (Target          : in out Tree;
-      Target_Parent   : Cursor;
-      Before          : Cursor;
-      Source          : in out Tree;
-      Source_Parent   : Cursor)
+     (Target        : in out Tree;
+      Target_Parent : Cursor;
+      Before        : Cursor;
+      Source        : in out Tree;
+      Source_Parent : Cursor)
    is
    begin
       if Target_Parent = No_Element then
@@ -2567,14 +2563,14 @@ package body Ada.Containers.Bounded_Multiway_Trees is
       --  Before we attempt the insertion, we must count the sources nodes in
       --  order to determine whether the target have enough storage
       --  available. Note that calculating this value is an O(n) operation.
-      --
+
       --  Here is an optimization opportunity: iterate of each children the
       --  source explicitly, and keep a running count of the total number of
       --  nodes. Compare the running total to the capacity of the target each
       --  pass through the loop. This is more efficient than summing the counts
       --  of child subtree (which is what Subtree_Node_Count does) and then
       --  comparing that total sum to the target's capacity.  ???
-      --
+
       --  Here is another possibility. We currently treat the splice as an
       --  all-or-nothing proposition: either we can insert all of children of
       --  the source, or we raise exception with modifying the target. The
@@ -2767,7 +2763,9 @@ package body Ada.Containers.Bounded_Multiway_Trees is
       end if;
 
       if Is_Root (Position) then
+
          --  Should this be PE instead?  Need ARG confirmation.  ???
+
          raise Constraint_Error with "Position cursor designates root";
       end if;
 
diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi
index 1cfcf71..a7f13a1 100644
--- a/gcc/ada/gnat_rm.texi
+++ b/gcc/ada/gnat_rm.texi
@@ -104,6 +104,7 @@ Implementation Defined Pragmas
 * Pragma Ada_2012::
 * Pragma Annotate::
 * Pragma Assert::
+* Pragma Assertion_Policy::
 * Pragma Assume_No_Invalid_Values::
 * Pragma Ast_Entry::
 * Pragma C_Pass_By_Copy::
@@ -737,6 +738,7 @@ consideration, the use of these pragmas should be minimized.
 * Pragma Ada_2012::
 * Pragma Annotate::
 * Pragma Assert::
+* Pragma Assertion_Policy::
 * Pragma Assume_No_Invalid_Values::
 * Pragma Ast_Entry::
 * Pragma C_Pass_By_Copy::
@@ -1075,6 +1077,43 @@ effect on the program.  However, the expressions are analyzed for
 semantic correctness whether or not assertions are enabled, so turning
 assertions on and off cannot affect the legality of a program.
 
+Note that the implementation defined policy @code{DISABLE}, given in a
+pragma Assertion_Policy, can be used to suppress this semantic analysis.
+
+Note: this is a standard language-defined pragma in versions
+of Ada from 2005 on. In GNAT, it is implemented in all versions
+of Ada, and the DISABLE policy is an implementation-defined
+addition.
+
+
+@node Pragma Assertion_Policy
+@unnumberedsec Pragma Assertion_Policy
+@findex Debug_Policy
+@noindent
+Syntax:
+
+@smallexample @c ada
+pragma Assertion_Policy (CHECK | DISABLE | IGNORE);
+@end smallexample
+
+@noindent
+If the argument is @code{CHECK}, then pragma @code{Assert} is enabled.
+If the argument is @code{IGNORE}, then pragma @code{Assert} is ignored.
+This pragma overrides the effect of the @option{-gnata} switch on the
+command line.
+
+The implementation defined policy @code{DISABLE} is like
+@code{IGNORE} except that it completely disables semantic
+checking of the argument to @code{pragma Assert}. This may
+be useful when the pragma argument references subprograms
+in a with'ed package which is replaced by a dummy package
+for the final build.
+
+Note: this is a standard language-defined pragma in versions
+of Ada from 2005 on. In GNAT, it is implemented in all versions
+of Ada, and the DISABLE policy is an implementation-defined
+addition.
+
 @node Pragma Assume_No_Invalid_Values
 @unnumberedsec Pragma Assume_No_Invalid_Values
 @findex Assume_No_Invalid_Values
@@ -1258,7 +1297,7 @@ pragma Check_Policy
  ([Name   =>] Identifier,
   [Policy =>] POLICY_IDENTIFIER);
 
-POLICY_IDENTIFIER ::= On | Off | Check | Ignore
+POLICY_IDENTIFIER ::= ON | OFF | CHECK | DISABLE | IGNORE
 @end smallexample
 
 @noindent
@@ -1273,7 +1312,7 @@ The identifier given as the first argument corresponds to a name used in
 associated @code{Check} pragmas. For example, if the pragma:
 
 @smallexample @c ada
-pragma Check_Policy (Critical_Error, Off);
+pragma Check_Policy (Critical_Error, OFF);
 @end smallexample
 
 @noindent
@@ -1291,15 +1330,22 @@ that @code{Precondition} checks are @code{Off} or @code{Ignored}. Similarly use
 of the name @code{Postcondition} controls whether @code{Postcondition} pragmas
 are recognized.
 
-The check policy is @code{Off} to turn off corresponding checks, and @code{On}
+The check policy is @code{OFF} to turn off corresponding checks, and @code{ON}
 to turn on corresponding checks. The default for a set of checks for which no
-@code{Check_Policy} is given is @code{Off} unless the compiler switch
+@code{Check_Policy} is given is @code{OFF} unless the compiler switch
 @option{-gnata} is given, which turns on all checks by default.
 
-The check policy settings @code{Check} and @code{Ignore} are also recognized
-as synonyms for @code{On} and @code{Off}. These synonyms are provided for
+The check policy settings @code{CHECK} and @code{IGNORE} are also recognized
+as synonyms for @code{ON} and @code{OFF}. These synonyms are provided for
 compatibility with the standard @code{Assertion_Policy} pragma.
 
+The implementation defined policy @code{DISABLE} is like
+@code{OFF} except that it completely disables semantic
+checking of the argument to the corresponding class of
+pragmas. This may be useful when the pragma arguments reference
+subprograms in a with'ed package which is replaced by a dummy package
+for the final build.
+
 @node Pragma Comment
 @unnumberedsec Pragma Comment
 @findex Comment
@@ -1719,7 +1765,7 @@ or by use of the configuration pragma @code{Debug_Policy}.
 Syntax:
 
 @smallexample @c ada
-pragma Debug_Policy (CHECK | IGNORE);
+pragma Debug_Policy (CHECK | DISABLE | IGNORE);
 @end smallexample
 
 @noindent
@@ -1728,6 +1774,13 @@ If the argument is @code{IGNORE}, then pragma @code{DEBUG} is ignored.
 This pragma overrides the effect of the @option{-gnata} switch on the
 command line.
 
+The implementation defined policy @code{DISABLE} is like
+@code{IGNORE} except that it completely disables semantic
+checking of the argument to @code{pragma Debug}. This may
+be useful when the pragma argument references subprograms
+in a with'ed package which is replaced by a dummy package
+for the final build.
+
 @node Pragma Detect_Blocking
 @unnumberedsec Pragma Detect_Blocking
 @findex Detect_Blocking
diff --git a/gcc/ada/opt.adb b/gcc/ada/opt.adb
index d850e69..ed76923 100644
--- a/gcc/ada/opt.adb
+++ b/gcc/ada/opt.adb
@@ -49,6 +49,7 @@ package body Opt is
       Assertions_Enabled_Config             := Assertions_Enabled;
       Assume_No_Invalid_Values_Config       := Assume_No_Invalid_Values;
       Check_Policy_List_Config              := Check_Policy_List;
+      Debug_Pragmas_Disabled_Config         := Debug_Pragmas_Disabled;
       Debug_Pragmas_Enabled_Config          := Debug_Pragmas_Enabled;
       Default_Pool_Config                   := Default_Pool;
       Dynamic_Elaboration_Checks_Config     := Dynamic_Elaboration_Checks;
@@ -82,6 +83,7 @@ package body Opt is
       Assertions_Enabled             := Save.Assertions_Enabled;
       Assume_No_Invalid_Values       := Save.Assume_No_Invalid_Values;
       Check_Policy_List              := Save.Check_Policy_List;
+      Debug_Pragmas_Disabled         := Save.Debug_Pragmas_Disabled;
       Debug_Pragmas_Enabled          := Save.Debug_Pragmas_Enabled;
       Default_Pool                   := Save.Default_Pool;
       Dynamic_Elaboration_Checks     := Save.Dynamic_Elaboration_Checks;
@@ -117,6 +119,7 @@ package body Opt is
       Save.Assertions_Enabled             := Assertions_Enabled;
       Save.Assume_No_Invalid_Values       := Assume_No_Invalid_Values;
       Save.Check_Policy_List              := Check_Policy_List;
+      Save.Debug_Pragmas_Disabled         := Debug_Pragmas_Disabled;
       Save.Debug_Pragmas_Enabled          := Debug_Pragmas_Enabled;
       Save.Default_Pool                   := Default_Pool;
       Save.Dynamic_Elaboration_Checks     := Dynamic_Elaboration_Checks;
@@ -168,11 +171,13 @@ package body Opt is
          if Main_Unit then
             Assertions_Enabled       := Assertions_Enabled_Config;
             Assume_No_Invalid_Values := Assume_No_Invalid_Values_Config;
+            Debug_Pragmas_Disabled   := Debug_Pragmas_Disabled_Config;
             Debug_Pragmas_Enabled    := Debug_Pragmas_Enabled_Config;
             Check_Policy_List        := Check_Policy_List_Config;
          else
             Assertions_Enabled       := False;
             Assume_No_Invalid_Values := False;
+            Debug_Pragmas_Disabled   := False;
             Debug_Pragmas_Enabled    := False;
             Check_Policy_List        := Empty;
          end if;
@@ -185,6 +190,7 @@ package body Opt is
          Assertions_Enabled          := Assertions_Enabled_Config;
          Assume_No_Invalid_Values    := Assume_No_Invalid_Values_Config;
          Check_Policy_List           := Check_Policy_List_Config;
+         Debug_Pragmas_Disabled      := Debug_Pragmas_Disabled_Config;
          Debug_Pragmas_Enabled       := Debug_Pragmas_Enabled_Config;
          Dynamic_Elaboration_Checks  := Dynamic_Elaboration_Checks_Config;
          Extensions_Allowed          := Extensions_Allowed_Config;
@@ -241,6 +247,7 @@ package body Opt is
       Tree_Read_Bool (All_Errors_Mode);
       Tree_Read_Bool (Assertions_Enabled);
       Tree_Read_Int  (Int (Check_Policy_List));
+      Tree_Read_Bool (Debug_Pragmas_Disabled);
       Tree_Read_Bool (Debug_Pragmas_Enabled);
       Tree_Read_Int  (Int (Default_Pool));
       Tree_Read_Bool (Enable_Overflow_Checks);
@@ -307,6 +314,7 @@ package body Opt is
       Tree_Write_Bool (All_Errors_Mode);
       Tree_Write_Bool (Assertions_Enabled);
       Tree_Write_Int  (Int (Check_Policy_List));
+      Tree_Write_Bool (Debug_Pragmas_Disabled);
       Tree_Write_Bool (Debug_Pragmas_Enabled);
       Tree_Write_Int  (Int (Default_Pool));
       Tree_Write_Bool (Enable_Overflow_Checks);
diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads
index d7cde53..a9c2d9f 100644
--- a/gcc/ada/opt.ads
+++ b/gcc/ada/opt.ads
@@ -374,6 +374,10 @@ package Opt is
    --  GNAT
    --  Enable debug statements from pragma Debug
 
+   Debug_Pragmas_Disabled : Boolean := False;
+   --  GNAT
+   --  Debug pragmas completely disabled (no semantic checking)
+
    subtype Debug_Level_Value is Nat range 0 .. 3;
    Debugger_Level : Debug_Level_Value := 0;
    --  GNATBIND
@@ -1661,6 +1665,11 @@ package Opt is
    --  terminated by Empty. The order is most recently processed first. This
    --  list includes only those pragmas in configuration pragma files.
 
+   Debug_Pragmas_Disabled_Config : Boolean;
+   --  GNAT
+   --  This is the value of the configuration switch for debug pragmas disabled
+   --  mode, as possibly set by use of the configuration pragma Debug_Policy.
+
    Debug_Pragmas_Enabled_Config : Boolean;
    --  GNAT
    --  This is the value of the configuration switch for debug pragmas enabled
@@ -1885,6 +1894,7 @@ private
       Assertions_Enabled             : Boolean;
       Assume_No_Invalid_Values       : Boolean;
       Check_Policy_List              : Node_Id;
+      Debug_Pragmas_Disabled         : Boolean;
       Debug_Pragmas_Enabled          : Boolean;
       Default_Pool                   : Node_Id;
       Dynamic_Elaboration_Checks     : Boolean;
diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index 1e4bbe4..419f6cf 100644
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -352,12 +352,18 @@ package body Sem_Prag is
       --  Check the specified argument Arg to make sure that it is a valid
       --  locking policy name. If not give error and raise Pragma_Exit.
 
-      procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id);
-      procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2, N3 : Name_Id);
-      procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2, N3, N4 : Name_Id);
+      procedure Check_Arg_Is_One_Of
+        (Arg                : Node_Id;
+         N1, N2             : Name_Id);
+      procedure Check_Arg_Is_One_Of
+        (Arg                : Node_Id;
+         N1, N2, N3         : Name_Id);
+      procedure Check_Arg_Is_One_Of
+        (Arg                : Node_Id;
+         N1, N2, N3, N4, N5 : Name_Id);
       --  Check the specified argument Arg to make sure that it is an
-      --  identifier whose name matches either N1 or N2 (or N3 if present).
-      --  If not then give error and raise Pragma_Exit.
+      --  identifier whose name matches either N1 or N2 (or N3, N4, N5 if
+      --  present). If not then give error and raise Pragma_Exit.
 
       procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id);
       --  Check the specified argument Arg to make sure that it is a valid
@@ -1055,8 +1061,8 @@ package body Sem_Prag is
       end Check_Arg_Is_One_Of;
 
       procedure Check_Arg_Is_One_Of
-        (Arg            : Node_Id;
-         N1, N2, N3, N4 : Name_Id)
+        (Arg                : Node_Id;
+         N1, N2, N3, N4, N5 : Name_Id)
       is
          Argx : constant Node_Id := Get_Pragma_Arg (Arg);
 
@@ -1067,11 +1073,11 @@ package body Sem_Prag is
            and then Chars (Argx) /= N2
            and then Chars (Argx) /= N3
            and then Chars (Argx) /= N4
+           and then Chars (Argx) /= N5
          then
             Error_Pragma_Arg ("invalid argument for pragma%", Argx);
          end if;
       end Check_Arg_Is_One_Of;
-
       ---------------------------------
       -- Check_Arg_Is_Queuing_Policy --
       ---------------------------------
@@ -6419,7 +6425,7 @@ package body Sem_Prag is
 
             Rewrite (N,
               Make_Pragma (Loc,
-                Chars => Name_Check,
+                Chars                        => Name_Check,
                 Pragma_Argument_Associations => Newa));
             Analyze (N);
          end Assert;
@@ -6428,7 +6434,7 @@ package body Sem_Prag is
          -- Assertion_Policy --
          ----------------------
 
-         --  pragma Assertion_Policy (Check | Ignore)
+         --  pragma Assertion_Policy (Check | Disable |Ignore)
 
          when Pragma_Assertion_Policy => Assertion_Policy : declare
             Policy : Node_Id;
@@ -6438,7 +6444,7 @@ package body Sem_Prag is
             Check_Valid_Configuration_Pragma;
             Check_Arg_Count (1);
             Check_No_Identifiers;
-            Check_Arg_Is_One_Of (Arg1, Name_Check, Name_Ignore);
+            Check_Arg_Is_One_Of (Arg1, Name_Check, Name_Disable, Name_Ignore);
 
             --  We treat pragma Assertion_Policy as equivalent to:
 
@@ -6863,6 +6869,14 @@ package body Sem_Prag is
 
             Check_Arg_Is_Identifier (Arg1);
 
+            --  Completely ignore if disabled
+
+            if Check_Disabled (Chars (Get_Pragma_Arg (Arg1))) then
+               Rewrite (N, Make_Null_Statement (Loc));
+               Analyze (N);
+               return;
+            end if;
+
             --  Indicate if pragma is enabled. The Original_Node reference here
             --  is to deal with pragma Assert rewritten as a Check pragma.
 
@@ -6948,7 +6962,7 @@ package body Sem_Prag is
          --    [Name   =>] IDENTIFIER,
          --    [Policy =>] POLICY_IDENTIFIER);
 
-         --  POLICY_IDENTIFIER ::= ON | OFF | CHECK | IGNORE
+         --  POLICY_IDENTIFIER ::= ON | OFF | CHECK | DISABLE | IGNORE
 
          --  Note: this is a configuration pragma, but it is allowed to appear
          --  anywhere else.
@@ -6959,7 +6973,7 @@ package body Sem_Prag is
             Check_Optional_Identifier (Arg1, Name_Name);
             Check_Optional_Identifier (Arg2, Name_Policy);
             Check_Arg_Is_One_Of
-              (Arg2, Name_On, Name_Off, Name_Check, Name_Ignore);
+              (Arg2, Name_On, Name_Off, Name_Check, Name_Disable, Name_Ignore);
 
             --  A Check_Policy pragma can appear either as a configuration
             --  pragma, or in a declarative part or a package spec (see RM
@@ -7608,6 +7622,14 @@ package body Sem_Prag is
          begin
             GNAT_Pragma;
 
+            --  Skip analysis if disabled
+
+            if Debug_Pragmas_Disabled then
+               Rewrite (N, Make_Null_Statement (Loc));
+               Analyze (N);
+               return;
+            end if;
+
             Cond :=
               New_Occurrence_Of
                 (Boolean_Literals (Debug_Pragmas_Enabled and Expander_Active),
@@ -7679,9 +7701,11 @@ package body Sem_Prag is
          when Pragma_Debug_Policy =>
             GNAT_Pragma;
             Check_Arg_Count (1);
-            Check_Arg_Is_One_Of (Arg1, Name_Check, Name_Ignore);
+            Check_Arg_Is_One_Of (Arg1, Name_Check, Name_Disable, Name_Ignore);
             Debug_Pragmas_Enabled :=
               Chars (Get_Pragma_Arg (Arg1)) = Name_Check;
+            Debug_Pragmas_Disabled :=
+              Chars (Get_Pragma_Arg (Arg1)) = Name_Disable;
 
          ---------------------
          -- Detect_Blocking --
@@ -14181,6 +14205,40 @@ package body Sem_Prag is
       End_Scope;
    end Analyze_TC_In_Decl_Part;
 
+   --------------------
+   -- Check_Disabled --
+   --------------------
+
+   function Check_Disabled (Nam : Name_Id) return Boolean is
+      PP : Node_Id;
+
+   begin
+      --  Loop through entries in check policy list
+
+      PP := Opt.Check_Policy_List;
+      loop
+         --  If there are no specific entries that matched, then nothing is
+         --  disabled, so return False.
+
+         if No (PP) then
+            return False;
+
+         --  Here we have an entry see if it matches
+
+         else
+            declare
+               PPA : constant List_Id := Pragma_Argument_Associations (PP);
+            begin
+               if Nam = Chars (Get_Pragma_Arg (First (PPA))) then
+                  return Chars (Get_Pragma_Arg (Last (PPA))) = Name_Disable;
+               else
+                  PP := Next_Pragma (PP);
+               end if;
+            end;
+         end if;
+      end loop;
+   end Check_Disabled;
+
    -------------------
    -- Check_Enabled --
    -------------------
diff --git a/gcc/ada/sem_prag.ads b/gcc/ada/sem_prag.ads
index 5d9c741..18ffcc3 100644
--- a/gcc/ada/sem_prag.ads
+++ b/gcc/ada/sem_prag.ads
@@ -54,9 +54,15 @@ package Sem_Prag is
    --  pragma as "spec expressions" (see section in Sem "Handling of Default
    --  and Per-Object Expressions...").
 
+   function Check_Disabled (Nam : Name_Id) return Boolean;
+   --  This function is used in connection with pragmas Assertion, Check,
+   --  Precondition, and Postcondition, to determine if Check pragmas (or
+   --  corresponding Assert, Precondition, or Postcondition pragmas) are
+   --  currently disabled (as set by a Policy pragma with the Disabled
+
    function Check_Enabled (Nam : Name_Id) return Boolean;
    --  This function is used in connection with pragmas Assertion, Check,
-   --  Precondition, and Postcondition to determine if Check pragmas (or
+   --  Precondition, and Postcondition, to determine if Check pragmas (or
    --  corresponding Assert, Precondition, or Postcondition pragmas) are
    --  currently active, as determined by the presence of -gnata on the
    --  command line (which sets the default), and the appearance of pragmas
diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl
index 6b0e9f3..252dbda 100644
--- a/gcc/ada/snames.ads-tmpl
+++ b/gcc/ada/snames.ads-tmpl
@@ -623,6 +623,7 @@ package Snames is
    Name_Copy                           : constant Name_Id := N + $;
    Name_D_Float                        : constant Name_Id := N + $;
    Name_Descriptor                     : constant Name_Id := N + $;
+   Name_Disable                        : constant Name_Id := N + $;
    Name_Dot_Replacement                : constant Name_Id := N + $;
    Name_Dynamic                        : constant Name_Id := N + $;
    Name_Ensures                        : constant Name_Id := N + $;