1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- A D A . C O N T A I N E R S . H E L P E R S --
9 -- Copyright (C) 2015-2024, Free Software Foundation, Inc. --
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. --
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. --
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 ------------------------------------------------------------------------------
28 with Ada
.Finalization
;
29 with System
.Atomic_Counters
;
31 package Ada
.Containers
.Helpers
is
32 pragma Annotate
(CodePeer
, Skip_Analysis
);
35 -- Miscellaneous helpers shared among various containers
37 package SAC
renames System
.Atomic_Counters
;
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.
43 type Tamper_Counts
is record
44 Busy
: aliased SAC
.Atomic_Unsigned
:= 0;
45 Lock
: aliased SAC
.Atomic_Unsigned
:= 0;
48 -- Busy is positive when tampering with cursors is prohibited. Busy and
49 -- Lock are both positive when tampering with elements is prohibited.
51 type Tamper_Counts_Access
is access all Tamper_Counts
;
52 for Tamper_Counts_Access
'Storage_Size use 0;
55 package Generic_Implementation
is
57 -- Generic package used in the implementation of containers.
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:
63 -- pragma Suppress (Container_Checks);
64 -- package My_Vectors is new Ada.Containers.Vectors (...);
66 -- should suppress all container-related checks within the instance
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.
77 Checks
: constant Boolean := Container_Checks
'Enabled;
78 T_Check
: constant Boolean :=
79 Container_Checks
'Enabled and Tampering_Check
'Enabled;
81 -- Reference_Control_Type is used as a component of reference types, to
82 -- prohibit tampering with elements so long as references exist.
84 type Reference_Control_Type
is
85 new Finalization
.Controlled
with record
86 T_Counts
: Tamper_Counts_Access
;
88 with Disable_Controlled
=> not T_Check
;
90 overriding
procedure Adjust
(Control
: in out Reference_Control_Type
);
91 pragma Inline
(Adjust
);
93 overriding
procedure Finalize
(Control
: in out Reference_Control_Type
);
94 pragma Inline
(Finalize
);
96 procedure Zero_Counts
(T_Counts
: out Tamper_Counts
);
97 pragma Inline
(Zero_Counts
);
98 -- Set Busy and Lock to zero
100 procedure Busy
(T_Counts
: in out Tamper_Counts
);
101 pragma Inline
(Busy
);
102 -- Prohibit tampering with cursors
104 procedure Unbusy
(T_Counts
: in out Tamper_Counts
);
105 pragma Inline
(Unbusy
);
106 -- Allow tampering with cursors
108 procedure Lock
(T_Counts
: in out Tamper_Counts
);
109 pragma Inline
(Lock
);
110 -- Prohibit tampering with elements
112 procedure Unlock
(T_Counts
: in out Tamper_Counts
);
113 pragma Inline
(Unlock
);
114 -- Allow tampering with elements
116 procedure TC_Check
(T_Counts
: Tamper_Counts
);
117 pragma Inline
(TC_Check
);
118 -- Tampering-with-cursors check
120 procedure TE_Check
(T_Counts
: Tamper_Counts
);
121 pragma Inline
(TE_Check
);
122 -- Tampering-with-elements check
124 ---------------------------------------
125 -- Queries of busy and locked status --
126 ---------------------------------------
128 -- These are never called when tampering checks are suppressed.
130 use type SAC
.Atomic_Unsigned
;
132 pragma Warnings
(Off
);
133 -- Otherwise, the -gnatw.n switch triggers unwanted warnings on the
134 -- references to atomic variables below.
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
);
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
);
144 pragma Warnings
(On
);
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.
155 -- With_Lock is the same as With_Busy, except it increments/decrements
156 -- BOTH Busy and Lock, thus prohibiting tampering with cursors.
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
);
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
);
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.
176 pragma Warnings
(Off
, "variable ""Busy*"" is not referenced");
177 pragma Warnings
(Off
, "variable ""Lock*"" is not referenced");
179 end Generic_Implementation
;
181 end Ada
.Containers
.Helpers
;