gcc/ada/a-conhel.adb

   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 --                                 B o d y                                  --
   8 --                                                                          --
   9 --             Copyright (C) 2015, 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 package body Ada.Containers.Helpers is
  29
  30    package body Generic_Implementation is
  31
  32       use type SAC.Atomic_Unsigned;
  33
  34       ------------
  35       -- Adjust --
  36       ------------
  37
  38       procedure Adjust (Control : in out Reference_Control_Type) is
  39          pragma Warnings (Off);
  40          --  GNAT warns here if checks are turned off, but assertions on
  41          pragma Assert (T_Check); -- not called if check suppressed
  42          pragma Warnings (On);
  43       begin
  44          if Control.T_Counts /= null then
  45             Lock (Control.T_Counts.all);
  46          end if;
  47       end Adjust;
  48
  49       ----------
  50       -- Busy --
  51       ----------
  52
  53       procedure Busy (T_Counts : in out Tamper_Counts) is
  54       begin
  55          if T_Check then
  56             SAC.Increment (T_Counts.Busy);
  57          end if;
  58       end Busy;
  59
  60       --------------
  61       -- Finalize --
  62       --------------
  63
  64       procedure Finalize (Control : in out Reference_Control_Type) is
  65          pragma Warnings (Off);
  66          pragma Assert (T_Check); -- not called if check suppressed
  67          pragma Warnings (On);
  68       begin
  69          if Control.T_Counts /= null then
  70             Unlock (Control.T_Counts.all);
  71             Control.T_Counts := null;
  72          end if;
  73       end Finalize;
  74
  75       --  No need to protect against double Finalize here, because these types
  76       --  are limited.
  77
  78       procedure Finalize (Busy : in out With_Busy) is
  79          pragma Warnings (Off);
  80          pragma Assert (T_Check); -- not called if check suppressed
  81          pragma Warnings (On);
  82       begin
  83          Unbusy (Busy.T_Counts.all);
  84       end Finalize;
  85
  86       procedure Finalize (Lock : in out With_Lock) is
  87          pragma Warnings (Off);
  88          pragma Assert (T_Check); -- not called if check suppressed
  89          pragma Warnings (On);
  90       begin
  91          Unlock (Lock.T_Counts.all);
  92       end Finalize;
  93
  94       ----------------
  95       -- Initialize --
  96       ----------------
  97
  98       procedure Initialize (Busy : in out With_Busy) is
  99          pragma Warnings (Off);
 100          pragma Assert (T_Check); -- not called if check suppressed
 101          pragma Warnings (On);
 102       begin
 103          Generic_Implementation.Busy (Busy.T_Counts.all);
 104       end Initialize;
 105
 106       procedure Initialize (Lock : in out With_Lock) is
 107          pragma Warnings (Off);
 108          pragma Assert (T_Check); -- not called if check suppressed
 109          pragma Warnings (On);
 110       begin
 111          Generic_Implementation.Lock (Lock.T_Counts.all);
 112       end Initialize;
 113
 114       ----------
 115       -- Lock --
 116       ----------
 117
 118       procedure Lock (T_Counts : in out Tamper_Counts) is
 119       begin
 120          if T_Check then
 121             SAC.Increment (T_Counts.Lock);
 122             SAC.Increment (T_Counts.Busy);
 123          end if;
 124       end Lock;
 125
 126       --------------
 127       -- TC_Check --
 128       --------------
 129
 130       procedure TC_Check (T_Counts : Tamper_Counts) is
 131       begin
 132          if T_Check and then T_Counts.Busy > 0 then
 133             raise Program_Error with
 134               "attempt to tamper with cursors";
 135          end if;
 136
 137          --  The lock status (which monitors "element tampering") always
 138          --  implies that the busy status (which monitors "cursor tampering")
 139          --  is set too; this is a representation invariant. Thus if the busy
 140          --  bit is not set, then the lock bit must not be set either.
 141
 142          pragma Assert (T_Counts.Lock = 0);
 143       end TC_Check;
 144
 145       --------------
 146       -- TE_Check --
 147       --------------
 148
 149       procedure TE_Check (T_Counts : Tamper_Counts) is
 150       begin
 151          if T_Check and then T_Counts.Lock > 0 then
 152             raise Program_Error with
 153               "attempt to tamper with elements";
 154          end if;
 155       end TE_Check;
 156
 157       ------------
 158       -- Unbusy --
 159       ------------
 160
 161       procedure Unbusy (T_Counts : in out Tamper_Counts) is
 162       begin
 163          if T_Check then
 164             SAC.Decrement (T_Counts.Busy);
 165          end if;
 166       end Unbusy;
 167
 168       ------------
 169       -- Unlock --
 170       ------------
 171
 172       procedure Unlock (T_Counts : in out Tamper_Counts) is
 173       begin
 174          if T_Check then
 175             SAC.Decrement (T_Counts.Lock);
 176             SAC.Decrement (T_Counts.Busy);
 177          end if;
 178       end Unlock;
 179
 180       -----------------
 181       -- Zero_Counts --
 182       -----------------
 183
 184       procedure Zero_Counts (T_Counts : out Tamper_Counts) is
 185       begin
 186          if T_Check then
 187             T_Counts := (others => <>);
 188          end if;
 189       end Zero_Counts;
 190
 191    end Generic_Implementation;
 192
 193 end Ada.Containers.Helpers;