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

gcc/ada/ChangeLog

+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

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

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);

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;

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
@@ -1056,7 +1062,7 @@ package body Sem_Prag is
 
       procedure Check_Arg_Is_One_Of
         (Arg                : Node_Id;
-         N1, N2, N3, N4 : Name_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 --
       ---------------------------------
@@ -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 --
    -------------------

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

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 + $;