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
28package 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
193end Ada.Containers.Helpers;
194