From 9b3956ddfccf087a37c4ed3abb034e12096fdcd1 Mon Sep 17 00:00:00 2001 From: Robert Dewar Date: Fri, 5 Aug 2011 15:36:47 +0000 Subject: [PATCH] a-cbmutr.adb: Minor reformatting 2011-08-05 Robert Dewar * a-cbmutr.adb: Minor reformatting (Allocate_Node): refactor node allocation algorithm 2011-08-05 Robert Dewar * 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 * gnat_rm.texi: Document implementation-defined policy DISABLE for pragmas Assertion_Policy, Check_Policy, Debug_Policy. From-SVN: r177459 --- gcc/ada/ChangeLog | 19 ++++++ gcc/ada/a-cbmutr.adb | 146 ++++++++++++++++++++-------------------- gcc/ada/gnat_rm.texi | 67 ++++++++++++++++-- gcc/ada/opt.adb | 8 +++ gcc/ada/opt.ads | 10 +++ gcc/ada/sem_prag.adb | 86 +++++++++++++++++++---- gcc/ada/sem_prag.ads | 8 ++- gcc/ada/snames.ads-tmpl | 1 + 8 files changed, 249 insertions(+), 96 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index c37c1de30d0..68f44141ba2 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,22 @@ +2011-08-05 Robert Dewar + + * a-cbmutr.adb: Minor reformatting + (Allocate_Node): refactor node allocation algorithm + +2011-08-05 Robert Dewar + + * 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 + + * gnat_rm.texi: Document implementation-defined policy DISABLE for + pragmas Assertion_Policy, Check_Policy, Debug_Policy. + 2011-08-05 Ed Schonberg * 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 1392a4fdc17..b365d47479c 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- -- @@ -38,6 +38,11 @@ package body Ada.Containers.Bounded_Multiway_Trees is procedure Initialize_Node (Container : in out Tree; Index : Count_Type); 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; @@ -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 1cfcf715960..a7f13a14122 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 d850e69fe24..ed76923d5f0 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 d7cde533426..a9c2d9f7570 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 1e4bbe4b26c..419f6cf962e 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 5d9c741b09d..18ffcc38a24 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 6b0e9f344b6..252dbda4181 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 + $; -- 2.30.2