gcc/ada/libgnat/a-conhel.ads

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT LIBRARY COMPONENTS                          --
   4 --                                                                          --
   5 --               A D A . C O N T A I N E R S . H E L P E R S                --
   6 --                                                                          --
   7 --                                 S p e c                                  --
   8 --                                                                          --
   9 --             Copyright (C) 2015-2024, Free Software Foundation, Inc.      --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
  17 --                                                                          --
  18 -- As a special exception under Section 7 of GPL version 3, you are granted --
  19 -- additional permissions described in the GCC Runtime Library Exception,   --
  20 -- version 3.1, as published by the Free Software Foundation.               --
  21 --                                                                          --
  22 -- You should have received a copy of the GNU General Public License and    --
  23 -- a copy of the GCC Runtime Library Exception along with this program;     --
  24 -- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
  25 -- <http://www.gnu.org/licenses/>.                                          --
  26 ------------------------------------------------------------------------------
  27
  28 with Ada.Finalization;
  29 with System.Atomic_Counters;
  30
  31 package Ada.Containers.Helpers is
  32    pragma Annotate (CodePeer, Skip_Analysis);
  33    pragma Pure;
  34
  35    --  Miscellaneous helpers shared among various containers
  36
  37    package SAC renames System.Atomic_Counters;
  38
  39    Count_Type_Last : constant := Count_Type'Last;
  40    --  Count_Type'Last as a universal_integer, so we can compare Index_Type
  41    --  values against this without type conversions that might overflow.
  42
  43    type Tamper_Counts is record
  44       Busy : aliased SAC.Atomic_Unsigned := 0;
  45       Lock : aliased SAC.Atomic_Unsigned := 0;
  46    end record;
  47
  48    --  Busy is positive when tampering with cursors is prohibited. Busy and
  49    --  Lock are both positive when tampering with elements is prohibited.
  50
  51    type Tamper_Counts_Access is access all Tamper_Counts;
  52    for Tamper_Counts_Access'Storage_Size use 0;
  53
  54    generic
  55    package Generic_Implementation is
  56
  57       --  Generic package used in the implementation of containers.
  58
  59       --  This needs to be generic so that the 'Enabled attribute will return
  60       --  the value that is relevant at the point where a container generic is
  61       --  instantiated. For example:
  62       --
  63       --     pragma Suppress (Container_Checks);
  64       --     package My_Vectors is new Ada.Containers.Vectors (...);
  65       --
  66       --  should suppress all container-related checks within the instance
  67       --  My_Vectors.
  68
  69       --  Shorthands for "checks enabled" and "tampering checks enabled". Note
  70       --  that suppressing either Container_Checks or Tampering_Check disables
  71       --  tampering checks. Note that this code needs to be in a generic
  72       --  package, because we want to take account of check suppressions at the
  73       --  instance. We use these flags, along with pragma Inline, to ensure
  74       --  that the compiler can optimize away the checks, as well as the
  75       --  tampering check machinery, when checks are suppressed.
  76
  77       Checks : constant Boolean := Container_Checks'Enabled;
  78       T_Check : constant Boolean :=
  79         Container_Checks'Enabled and Tampering_Check'Enabled;
  80
  81       --  Reference_Control_Type is used as a component of reference types, to
  82       --  prohibit tampering with elements so long as references exist.
  83
  84       type Reference_Control_Type is
  85          new Finalization.Controlled with record
  86             T_Counts : Tamper_Counts_Access;
  87          end record
  88            with Disable_Controlled => not T_Check;
  89
  90       overriding procedure Adjust (Control : in out Reference_Control_Type);
  91       pragma Inline (Adjust);
  92
  93       overriding procedure Finalize (Control : in out Reference_Control_Type);
  94       pragma Inline (Finalize);
  95
  96       procedure Zero_Counts (T_Counts : out Tamper_Counts);
  97       pragma Inline (Zero_Counts);
  98       --  Set Busy and Lock to zero
  99
 100       procedure Busy (T_Counts : in out Tamper_Counts);
 101       pragma Inline (Busy);
 102       --  Prohibit tampering with cursors
 103
 104       procedure Unbusy (T_Counts : in out Tamper_Counts);
 105       pragma Inline (Unbusy);
 106       --  Allow tampering with cursors
 107
 108       procedure Lock (T_Counts : in out Tamper_Counts);
 109       pragma Inline (Lock);
 110       --  Prohibit tampering with elements
 111
 112       procedure Unlock (T_Counts : in out Tamper_Counts);
 113       pragma Inline (Unlock);
 114       --  Allow tampering with elements
 115
 116       procedure TC_Check (T_Counts : Tamper_Counts);
 117       pragma Inline (TC_Check);
 118       --  Tampering-with-cursors check
 119
 120       procedure TE_Check (T_Counts : Tamper_Counts);
 121       pragma Inline (TE_Check);
 122       --  Tampering-with-elements check
 123
 124       ---------------------------------------
 125       -- Queries of busy and locked status --
 126       ---------------------------------------
 127
 128       --  These are never called when tampering checks are suppressed.
 129
 130       use type SAC.Atomic_Unsigned;
 131
 132       pragma Warnings (Off);
 133       --  Otherwise, the -gnatw.n switch triggers unwanted warnings on the
 134       --  references to atomic variables below.
 135
 136       function Is_Busy (T_Counts : Tamper_Counts) return Boolean is
 137         (if T_Check then T_Counts.Busy > 0 else raise Program_Error);
 138       pragma Inline (Is_Busy);
 139
 140       function Is_Locked (T_Counts : Tamper_Counts) return Boolean is
 141         (if T_Check then T_Counts.Lock > 0 else raise Program_Error);
 142       pragma Inline (Is_Locked);
 143
 144       pragma Warnings (On);
 145
 146       ----------------
 147       -- RAII Types --
 148       ----------------
 149
 150       --  Initialize of With_Busy increments the Busy count, and Finalize
 151       --  decrements it. Thus, to prohibit tampering with elements within a
 152       --  given scope, declare an object of type With_Busy. The Busy count
 153       --  will be correctly decremented in case of exception or abort.
 154
 155       --  With_Lock is the same as With_Busy, except it increments/decrements
 156       --  BOTH Busy and Lock, thus prohibiting tampering with cursors.
 157
 158       type With_Busy (T_Counts : not null access Tamper_Counts) is
 159         new Finalization.Limited_Controlled with null record
 160           with Disable_Controlled => not T_Check;
 161       overriding procedure Initialize (Busy : in out With_Busy);
 162       overriding procedure Finalize (Busy : in out With_Busy);
 163
 164       type With_Lock (T_Counts : not null access Tamper_Counts) is
 165         new Finalization.Limited_Controlled with null record
 166           with Disable_Controlled => not T_Check;
 167       overriding procedure Initialize (Lock : in out With_Lock);
 168       overriding procedure Finalize (Lock : in out With_Lock);
 169
 170       --  Variables of type With_Busy and With_Lock are declared only for the
 171       --  effects of Initialize and Finalize, so they are not referenced;
 172       --  disable warnings about that. Note that all variables of these types
 173       --  have names starting with "Busy" or "Lock". These pragmas need to be
 174       --  present wherever these types are used.
 175
 176       pragma Warnings (Off, "variable ""Busy*"" is not referenced");
 177       pragma Warnings (Off, "variable ""Lock*"" is not referenced");
 178
 179    end Generic_Implementation;
 180
 181 end Ada.Containers.Helpers;